From 52f371dffbcd5fb246eb1d7515393a6b59f06e89 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Sat, 5 Aug 2023 12:34:19 -0700 Subject: [PATCH 01/19] ormolu formatting. ghc 9.6 as default. drop ghc 9.0 support (#211) upgrade ormolu-action with explict ormolu version. * flake update. remove unused packages * support ghc962 * ormolu formatting * additional ormolu formatting * CI: ghc 9.6.2 as default and update ormolu-action * update cabal files * explicit version * further formatting --- .github/workflows/build.yml | 42 ++++---- fficxx-runtime/fficxx-runtime.cabal | 5 +- .../src/FFICXX/Runtime/CodeGen/Cxx.hs | 3 +- fficxx-runtime/src/FFICXX/Runtime/TH.hs | 6 -- fficxx/fficxx.cabal | 8 +- fficxx/src/FFICXX/Generate/Code/Cabal.hs | 3 - fficxx/src/FFICXX/Generate/Code/Cpp.hs | 95 +++++++++---------- fficxx/src/FFICXX/Generate/Code/HsCast.hs | 14 +-- fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs | 15 ++- fficxx/src/FFICXX/Generate/Code/HsTemplate.hs | 12 +-- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 5 - fficxx/src/FFICXX/Generate/ContentMaker.hs | 20 ---- fficxx/src/FFICXX/Generate/Dependency.hs | 24 +---- fficxx/src/FFICXX/Generate/Name.hs | 7 -- fficxx/src/FFICXX/Generate/Util.hs | 4 +- flake.lock | 6 +- flake.nix | 2 +- 17 files changed, 104 insertions(+), 167 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 4d8997a2..a8972510 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -15,36 +15,38 @@ jobs: uses: cachix/install-nix-action@v16 with: nix_path: nixpkgs=channel:nixos-unstable - - name: build fficxx-runtime (GHC 9.4.2) + - name: build fficxx-runtime (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.fficxx-runtime - - name: build fficxx (GHC 9.4.2) + nix build --print-build-logs .#ghc962.fficxx-runtime + - name: build fficxx (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.fficxx - - name: build stdcxx (GHC 9.4.2) + nix build --print-build-logs .#ghc945.fficxx + - name: build stdcxx (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.stdcxx - - name: build fficxx-test (GHC 9.4.2) + nix build --print-build-logs .#ghc962.stdcxx + - name: build fficxx-test (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.fficxx-test - - name: build fficxx-multipkg-test (GHC 9.4.2) + nix build --print-build-logs .#ghc962.fficxx-test + - name: build fficxx-multipkg-test (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.fficxx-multipkg-test - - name: build tmf-test (GHC 9.4.2) + nix build --print-build-logs .#ghc962.fficxx-multipkg-test + - name: build tmf-test (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.tmf-test - - name: build tmpl-dep-test (GHC 9.4.2) + nix build --print-build-logs .#ghc962.tmf-test + - name: build tmpl-dep-test (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.tmpl-dep-test - - name: build tmpl-dup-inst (GHC 9.4.2) + nix build --print-build-logs .#ghc962.tmpl-dep-test + - name: build tmpl-dup-inst (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.tmpl-dup-inst - - name: build tmpl-toplevel-test (GHC 9.4.2) + nix build --print-build-logs .#ghc962.tmpl-dup-inst + - name: build tmpl-toplevel-test (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc942.tmpl-toplevel-test + nix build --print-build-logs .#ghc962.tmpl-toplevel-test format: runs-on: ubuntu-20.04 steps: - uses: actions/checkout@v2 - # ormolu 0.3.0.1 - - uses: mrkkrp/ormolu-action@v4 + # ormolu 0.5.0.1 + - uses: mrkkrp/ormolu-action@v14 + with: + version: 0.5.0.1 \ No newline at end of file diff --git a/fficxx-runtime/fficxx-runtime.cabal b/fficxx-runtime/fficxx-runtime.cabal index 2729d652..8f0f4c9e 100644 --- a/fficxx-runtime/fficxx-runtime.cabal +++ b/fficxx-runtime/fficxx-runtime.cabal @@ -1,6 +1,6 @@ Cabal-Version: 3.0 Name: fficxx-runtime -Version: 0.7.0.1 +Version: 0.8.0.0 Synopsis: Runtime for fficxx-generated library Description: Runtime for fficxx-generated library. fficxx is an automatic haskell Foreign Function Interface (FFI) generator to C++. @@ -9,7 +9,7 @@ License-file: LICENSE Author: Ian-Woo Kim Maintainer: Ian-Woo Kim Build-Type: Simple -Tested-With: GHC == 9.0.2 || == 9.2.4 || == 9.4.2 +Tested-With: GHC == 9.2.7 || == 9.4.5 || == 9.6.2 Category: FFI Tools Extra-Source-Files: ChangeLog.md @@ -38,5 +38,6 @@ Library Function.h cpp_magic.h ghc-options: -Wall + -Wunused-packages -funbox-strict-fields -fno-warn-unused-do-bind diff --git a/fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs b/fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs index 423922ce..e6856d74 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs @@ -270,7 +270,8 @@ renderCMacro (Include (HdrName hdr)) = "\n#include \"" <> hdr <> "\"\n" renderCMacro (Pragma param) = "\n#pragma " <> renderPragmaParam param <> "\n" renderCMacro (Undef n) = "\n#undef " <> renderCName n <> "\n" renderCMacro (Define m ts stmts) = - "\n#define " <> renderCName m + "\n#define " + <> renderCName m <> case ts of [] -> " " _ -> "(" <> intercalate ", " (map renderCName ts) <> ") \\\n" diff --git a/fficxx-runtime/src/FFICXX/Runtime/TH.hs b/fficxx-runtime/src/FFICXX/Runtime/TH.hs index 88ea8120..f28ee7c9 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/TH.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/TH.hs @@ -51,11 +51,9 @@ data FunctionParamInfo = FPInfo con :: String -> Type con = ConT . mkNameS --- | mkInstance :: Cxt -> Type -> [Dec] -> Dec mkInstance = InstanceD Nothing --- | mkTFunc :: (types, String, String -> String, types -> Q Type) -> Q Exp mkTFunc (typs, suffix, nf, tyf) = do @@ -66,7 +64,6 @@ mkTFunc (typs, suffix, nf, tyf) = addTopDecls [d] [|$(varE n)|] --- | mkMember :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec mkMember fname f typ suffix = do let x = mkNameS "x" @@ -74,7 +71,6 @@ mkMember fname f typ suffix = do pure $ FunD (mkNameS fname) [Clause [VarP x] (NormalB (AppE e (VarE x))) []] --- | mkNew :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec mkNew fname f typ suffix = do e <- f typ suffix @@ -83,11 +79,9 @@ mkNew fname f typ suffix = do (mkNameS fname) [Clause [] (NormalB e) []] --- | mkDelete :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec mkDelete = mkMember --- | mkFunc :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec mkFunc fname f typ suffix = do let x = mkNameS "x" diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 6a2ecb4b..757b8a27 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -1,6 +1,6 @@ Cabal-Version: 3.0 Name: fficxx -Version: 0.7.0.1 +Version: 0.8.0.0 Synopsis: Automatic C++ binding generation Description: fficxx is an automatic haskell Foreign Function Interface (FFI) generator to C++. License: BSD-2-Clause @@ -8,7 +8,7 @@ License-file: LICENSE Author: Ian-Woo Kim Maintainer: Ian-Woo Kim Build-Type: Simple -Tested-With: GHC == 9.0.2 || == 9.2.4 || == 9.4.2 +Tested-With: GHC == 9.2.7 || == 9.4.5 || == 9.6.2 Category: FFI Tools Extra-Source-Files: ChangeLog.md @@ -25,12 +25,9 @@ Library , aeson-pretty , array , bytestring - , Cabal , containers - , data-default , directory , dotgen - , errors , fficxx-runtime , filepath>1 , hashable @@ -71,6 +68,7 @@ Library FFICXX.Generate.Type.Module FFICXX.Generate.Type.PackageInterface ghc-options: -Wall + -Wunused-packages -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-missing-signatures diff --git a/fficxx/src/FFICXX/Generate/Code/Cabal.hs b/fficxx/src/FFICXX/Generate/Code/Cabal.hs index 3cec76d9..7c699752 100644 --- a/fficxx/src/FFICXX/Generate/Code/Cabal.hs +++ b/fficxx/src/FFICXX/Generate/Code/Cabal.hs @@ -135,7 +135,6 @@ genPkgDeps cs = ] ++ map unCabalName cs --- | cabalTemplate :: Text cabalTemplate = "Cabal-version: 3.0\n\ @@ -261,7 +260,6 @@ genCabalFile GeneratedCabalInfo {..} = ("pkgconfigDepends", T.intercalate ", " gci_pkgconfigDepends) ] --- | buildCabalFile :: Cabal -> String -> @@ -278,7 +276,6 @@ buildCabalFile cabal summarymodule pkgconfig extralibs cxxopts cabalfile = do txt = genCabalFile cinfo TIO.writeFile cabalfile txt --- | buildJSONFile :: Cabal -> String -> diff --git a/fficxx/src/FFICXX/Generate/Code/Cpp.hs b/fficxx/src/FFICXX/Generate/Code/Cpp.hs index f3abe7f6..81907b98 100644 --- a/fficxx/src/FFICXX/Generate/Code/Cpp.hs +++ b/fficxx/src/FFICXX/Generate/Code/Cpp.hs @@ -341,7 +341,6 @@ genTmplVarCpp b t@TmplCls {..} var@(Variable (Arg {})) = (R.CVar (R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix))) ] --- | genTmplClassCpp :: IsCPrimitive -> TemplateClass -> @@ -363,7 +362,6 @@ genTmplClassCpp b TmplCls {..} (fs, vs) = map macro1 fs ++ (map macro1 . concatMap (\v -> [tmplAccessorToTFun v Getter, tmplAccessorToTFun v Setter])) vs --- | returnCpp :: IsCPrimitive -> Types -> @@ -499,60 +497,60 @@ returnCpp b ret caller = funcToDecl :: Class -> Function -> R.CFunDecl Identity funcToDecl c func | isNewFunc func || isStaticFunc func = - let ret = returnCType (genericFuncRet func) - fname = - R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)] - args = argsToCTypVarNoSelf (genericFuncArgs func) - in R.CFunDecl ret fname args + let ret = returnCType (genericFuncRet func) + fname = + R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)] + args = argsToCTypVarNoSelf (genericFuncArgs func) + in R.CFunDecl ret fname args | otherwise = - let ret = returnCType (genericFuncRet func) - fname = - R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)] - args = argsToCTypVar (genericFuncArgs func) - in R.CFunDecl ret fname args + let ret = returnCType (genericFuncRet func) + fname = + R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)] + args = argsToCTypVar (genericFuncArgs func) + in R.CFunDecl ret fname args funcToDef :: Class -> Function -> R.CStatement Identity funcToDef c func | isNewFunc func = - let body = - [ R.CInit - (R.CVarDecl (R.CTStar (R.CTSimple (R.sname "Type"))) (R.sname "newp")) - (R.CNew (R.sname "Type") $ map argToCallCExp (genericFuncArgs func)), - R.CReturn $ - R.CTApp - (R.sname "from_nonconst_to_nonconst") - [R.CTSimple (R.CName [R.NamePart "Type", R.NamePart "_t"]), R.CTSimple (R.sname "Type")] - [R.CVar (R.sname "newp")] - ] - in R.CDefinition Nothing (funcToDecl c func) body + let body = + [ R.CInit + (R.CVarDecl (R.CTStar (R.CTSimple (R.sname "Type"))) (R.sname "newp")) + (R.CNew (R.sname "Type") $ map argToCallCExp (genericFuncArgs func)), + R.CReturn $ + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [R.CTSimple (R.CName [R.NamePart "Type", R.NamePart "_t"]), R.CTSimple (R.sname "Type")] + [R.CVar (R.sname "newp")] + ] + in R.CDefinition Nothing (funcToDecl c func) body | isDeleteFunc func = - let body = - [ R.CDelete $ - R.CTApp - (R.sname "from_nonconst_to_nonconst") - [R.CTSimple (R.sname "Type"), R.CTSimple (R.CName [R.NamePart "Type", R.NamePart "_t"])] - [R.CVar (R.sname "p")] - ] - in R.CDefinition Nothing (funcToDecl c func) body + let body = + [ R.CDelete $ + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [R.CTSimple (R.sname "Type"), R.CTSimple (R.CName [R.NamePart "Type", R.NamePart "_t"])] + [R.CVar (R.sname "p")] + ] + in R.CDefinition Nothing (funcToDecl c func) body | isStaticFunc func = - let body = - returnCpp NonCPrim (genericFuncRet func) $ - R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func)) - in R.CDefinition Nothing (funcToDecl c func) body + let body = + returnCpp NonCPrim (genericFuncRet func) $ + R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func)) + in R.CDefinition Nothing (funcToDecl c func) body | otherwise = - let caller = - R.CBinOp - R.CArrow - ( R.CApp - ( R.CEMacroApp - (R.sname "TYPECASTMETHOD") - [R.sname "Type", R.sname (aliasedFuncName c func), R.sname (class_name c)] - ) - [R.CVar (R.sname "p")] - ) - (R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func))) - body = returnCpp NonCPrim (genericFuncRet func) caller - in R.CDefinition Nothing (funcToDecl c func) body + let caller = + R.CBinOp + R.CArrow + ( R.CApp + ( R.CEMacroApp + (R.sname "TYPECASTMETHOD") + [R.sname "Type", R.sname (aliasedFuncName c func), R.sname (class_name c)] + ) + [R.CVar (R.sname "p")] + ) + (R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func))) + body = returnCpp NonCPrim (genericFuncRet func) caller + in R.CDefinition Nothing (funcToDecl c func) body -- template function declaration and definition @@ -674,7 +672,6 @@ topLevelTemplateFunToDef b t@TopLevelTemplateFunction {..} = typparams (map (tmplArgToCallCExp b) topleveltfunc_args) --- | tmplVarToDef :: IsCPrimitive -> TemplateClass -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs index 4e3c5b4d..6c0c140d 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCast.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCast.hs @@ -32,16 +32,16 @@ castBody = 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) + 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) + let (cname, rname) = hsClassName c + in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody) | otherwise = Nothing diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs index 447d28b0..28b294ab 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -132,12 +132,12 @@ genHsFrontDecl isHsBoot c = do 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] + 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 = [] --------------------- @@ -342,7 +342,7 @@ mkImportWithDepCycles depCycles self imported = in case mloc of Just (idxSelf, idxImported) | idxImported > idxSelf -> - mkImportSrc imported + mkImportSrc imported _ -> mkImport imported genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()] @@ -359,7 +359,6 @@ genImportInInterface isHsBoot depCycles m = in fmap mkImport imported' else fmap (mkImportWithDepCycles depCycles modSelf . subModuleName) imported --- | genImportInCast :: ClassModule -> [ImportDecl ()] genImportInCast m = fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m diff --git a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs index 7edb625d..01aee805 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs @@ -234,7 +234,6 @@ genImportInTemplate :: TemplateClass -> [ImportDecl ()] genImportInTemplate t0 = fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTemplate, t0) --- | genTmplInterface :: TemplateClass -> [Decl ()] genTmplInterface t = [ mkData rname (map mkTBind tps) [] Nothing, @@ -266,12 +265,10 @@ genTmplInterface t = insDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing) ] --- | genImportInTH :: TemplateClass -> [ImportDecl ()] genImportInTH t0 = fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0) --- | genTmplImplementation :: TemplateClass -> [Decl ()] genTmplImplementation t = concatMap gen (tclass_funcs t) ++ concatMap genV (tclass_vars t) @@ -313,7 +310,6 @@ genTmplImplementation t = f_s = tmplAccessorToTFun vf Setter in gen f_g ++ gen f_s --- | genTmplInstance :: TemplateClassImportHeader -> [Decl ()] @@ -386,7 +382,8 @@ genTmplInstance tcih = gen prefix nm f n = generator (p (prefix <> show n)) - ( v nm `app` strE (hsTmplFuncName t f) + ( v nm + `app` strE (hsTmplFuncName t f) `app` v (hsTmplFuncNameTH t f) `app` typs_v `app` v "suffix" @@ -502,7 +499,6 @@ genTmplInstance tcih = -- top-level -- --------------- --- | genTLTemplateInterface :: TLTemplate -> [Decl ()] genTLTemplateInterface t = [ mkClass cxEmpty (firstUpper (topleveltfunc_name t)) (map mkTBind tps) methods @@ -514,7 +510,6 @@ genTLTemplateInterface t = sigdecl = mkFunSig (topleveltfunc_name t) $ foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) methods = [clsDecl sigdecl] --- | genTLTemplateImplementation :: TLTemplate -> [Decl ()] genTLTemplateImplementation t = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) @@ -627,7 +622,8 @@ genTLTemplateInstance tih t = genstmt prefix n = generator (p (prefix <> show n)) - ( v "mkFunc" `app` strE (topleveltfunc_name t) + ( v "mkFunc" + `app` strE (topleveltfunc_name t) `app` v ("t_" <> topleveltfunc_name t) `app` typs_v `app` v "suffix" diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index ec922d9b..1d9bb18e 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -632,7 +632,6 @@ tmplReturnCType b (TemplateParamPointer t) = case b of -- Template Member Function -- -- --------------------------- --- | tmplMemFuncArgToCTypVar :: Class -> Arg -> (R.CType Identity, R.CName Identity) tmplMemFuncArgToCTypVar _ (Arg (CT ctyp isconst) varname) = (ctypToCType ctyp isconst, R.sname varname) @@ -658,7 +657,6 @@ tmplMemFuncArgToCTypVar _ (Arg (TemplateParam t) v) = (R.CTSimple (R.CName [R.Na tmplMemFuncArgToCTypVar _ (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.CName [R.NamePart t, R.NamePart "_p"]), R.sname v) tmplMemFuncArgToCTypVar _ _ = error "tmplMemFuncArgToString: undefined" --- | tmplMemFuncReturnCType :: Class -> Types -> R.CType Identity tmplMemFuncReturnCType _ (CT ctyp isconst) = ctypToCType ctyp isconst tmplMemFuncReturnCType _ Void = R.CTVoid @@ -674,7 +672,6 @@ tmplMemFuncReturnCType _ (TemplateType _) = R.CTStar R.CTVoid tmplMemFuncReturnCType _ (TemplateParam t) = R.CTSimple $ R.CName [R.NamePart t, R.NamePart "_p"] tmplMemFuncReturnCType _ (TemplateParamPointer t) = R.CTSimple $ R.CName [R.NamePart t, R.NamePart "_p"] --- | convertC2HS :: CTypes -> Type () convertC2HS CTBool = tycon "CBool" convertC2HS CTChar = tycon "CChar" @@ -719,7 +716,6 @@ convertC2HS (CEnum t _) = convertC2HS t convertC2HS (CPointer t) = tyapp (tycon "Ptr") (convertC2HS t) convertC2HS (CRef t) = tyapp (tycon "Ptr") (convertC2HS t) --- | convertCpp2HS :: Maybe Class -> Types -> Type () convertCpp2HS _c Void = unit_tycon convertCpp2HS (Just c) SelfType = tycon ((fst . hsClassName) c) @@ -747,7 +743,6 @@ convertCpp2HS _c (TemplateType t) = convertCpp2HS _c (TemplateParam p) = mkTVar p convertCpp2HS _c (TemplateParamPointer p) = mkTVar p --- | convertCpp2HS4Tmpl :: -- | self Type () -> diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 79417d8e..9afb8d6c 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -133,11 +133,9 @@ csrcDir installbasedir = installbasedir "csrc" ---- common function for daughter --- | mkGlobal :: [Class] -> ClassGlobal mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap --- | buildDaughterDef :: ((String, [Class]) -> String) -> DaughterMap -> @@ -147,11 +145,9 @@ buildDaughterDef f m = f' (x, xs) = f (x, filter (not . isAbstractClass) xs) in (concatMap f' lst) --- | buildParentDef :: ((Class, Class) -> [R.CStatement Identity]) -> Class -> [R.CStatement Identity] buildParentDef f cls = concatMap (\p -> f (p, cls)) . class_allparents $ cls --- | mkProtectedFunctionList :: Class -> [R.CMacro Identity] mkProtectedFunctionList c = map (\x -> R.Define (R.sname ("IS_" <> class_name c <> "_" <> x <> "_PROTECTED")) [] [R.CVerbatim "()"]) @@ -159,7 +155,6 @@ mkProtectedFunctionList c = . class_protected $ c --- | buildTypeDeclHeader :: [Class] -> String @@ -171,7 +166,6 @@ buildTypeDeclHeader classes = R.ExternC $ [R.Pragma R.Once, R.EmptyLine] <> typeDeclBodyStmts --- | buildDeclHeader :: -- | C prefix String -> @@ -211,7 +205,6 @@ buildDeclHeader cprefix header = <> [R.EmptyLine] <> map R.CRegular classDeclStmts --- | buildDefMain :: ClassImportHeader -> String @@ -267,7 +260,6 @@ buildDefMain cih = <> cppBodyStmts ) --- | buildTopLevelHeader :: -- | C prefix String -> @@ -285,7 +277,6 @@ buildTopLevelHeader cprefix tih = <> [R.EmptyLine] <> map R.CRegular declBodyStmts --- | buildTopLevelCppDef :: TopLevelImportHeader -> String buildTopLevelCppDef tih = let cihs = tihClassDep tih @@ -335,7 +326,6 @@ buildTopLevelCppDef tih = ] ) --- | buildFFIHsc :: ClassModule -> Module () buildFFIHsc m = mkModule @@ -356,7 +346,6 @@ buildFFIHsc m = <> genExtraImport m hscBody = genHsFFI (cmCIH m) --- | buildRawTypeHs :: ClassModule -> Module () buildRawTypeHs m = mkModule @@ -383,7 +372,6 @@ buildRawTypeHs m = let c = cihClass (cmCIH m) in if isAbstractClass c then [] else hsClassRawType c --- | buildInterfaceHs :: AnnotateMap -> DepCycles -> @@ -422,7 +410,6 @@ buildInterfaceHs amap depCycles m = <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes --- | buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module () buildInterfaceHsBoot depCycles m = mkModule @@ -455,7 +442,6 @@ buildInterfaceHsBoot depCycles m = hsbootBody = runReader (mapM (genHsFrontDecl True) [c]) M.empty --- | buildCastHs :: ClassModule -> Module () buildCastHs m = mkModule @@ -483,7 +469,6 @@ buildCastHs m = mapMaybe genHsFrontInstCastable classes <> mapMaybe genHsFrontInstCastableSelf classes --- | buildImplementationHs :: AnnotateMap -> ClassModule -> Module () buildImplementationHs amap m = mkModule @@ -600,13 +585,11 @@ buildTHHs m = tmplImpls = genTmplImplementation t tmplInsts = genTmplInstance (tcmTCIH m) --- | buildModuleHs :: ClassModule -> Module () buildModuleHs m = mkModuleE (cmModule m) [] (genExport c) (genImportInModule c) [] where c = cihClass (cmCIH m) --- | buildTopLevelHs :: String -> ([ClassModule], [TemplateClassModule]) -> @@ -655,7 +638,6 @@ buildTopLevelOrdinaryHs modname (_mods, tmods) tih = map (genTopLevelFFI tih) (filterTLOrdinary tfns) ++ concatMap genTopLevelDef (filterTLOrdinary tfns) --- | buildTopLevelTemplateHs :: String -> TopLevelImportHeader -> @@ -691,7 +673,6 @@ buildTopLevelTemplateHs modname tih = ++ concatMap genImportForTLTemplate tfns pkgBody = concatMap genTLTemplateInterface tfns --- | buildTopLevelTHHs :: String -> TopLevelImportHeader -> @@ -735,7 +716,6 @@ buildTopLevelTHHs modname tih = concatMap genTLTemplateImplementation tfns <> concatMap (genTLTemplateInstance tih) tfns --- | buildPackageInterface :: PackageInterface -> PackageName -> diff --git a/fficxx/src/FFICXX/Generate/Dependency.hs b/fficxx/src/FFICXX/Generate/Dependency.hs index d6ea68a7..f3af93e7 100644 --- a/fficxx/src/FFICXX/Generate/Dependency.hs +++ b/fficxx/src/FFICXX/Generate/Dependency.hs @@ -93,7 +93,6 @@ getFFIName = either tclass_name ffiClassName getPkgName :: Either TemplateClass Class -> CabalName getPkgName = cabal_pkgname . getcabal --- | extractClassFromType :: Types -> [Either TemplateClass Class] extractClassFromType Void = [] extractClassFromType SelfType = [] @@ -152,7 +151,6 @@ data Dep4Func = Dep4Func argumentDependency :: [Either TemplateClass Class] } --- | extractClassDep :: Function -> Dep4Func extractClassDep (Constructor args _) = Dep4Func [] (concatMap classFromArg args) @@ -165,7 +163,6 @@ extractClassDep (Static ret _ args _) = extractClassDep (Destructor _) = Dep4Func [] [] --- | extractClassDepForTmplFun :: TemplateFunction -> Dep4Func extractClassDepForTmplFun (TFun ret _ _ args) = Dep4Func (extractClassFromType ret) (concatMap classFromArg args) @@ -176,12 +173,10 @@ extractClassDepForTmplFun TFunDelete = extractClassDepForTmplFun (TFunOp ret _ e) = Dep4Func (extractClassFromType ret) (concatMap classFromArg $ argsFromOpExp e) --- | extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func extractClassDep4TmplMemberFun (TemplateMemberFunction {..}) = Dep4Func (extractClassFromType tmf_ret) (concatMap classFromArg tmf_args) --- | extractClassDepForTLOrdinary :: TLOrdinary -> Dep4Func extractClassDepForTLOrdinary f = Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType . arg_type) args) @@ -193,7 +188,6 @@ extractClassDepForTLOrdinary f = TopLevelFunction {..} -> toplevelfunc_args TopLevelVariable {} -> [] --- | extractClassDepForTLTemplate :: TLTemplate -> Dep4Func extractClassDepForTLTemplate f = Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType . arg_type) args) @@ -273,7 +267,8 @@ calculateDependency (Right (CSTInterface, cls)) = inplaces = fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ L.nub $ - filter (`isInSamePackageButNotInheritedBy` Right cls) $ argDepClasses + filter (`isInSamePackageButNotInheritedBy` Right cls) $ + argDepClasses in rawSelf : (raws ++ exts ++ inplaces) calculateDependency (Right (CSTCast, cls)) = [Right (CSTRawType, cls), Right (CSTInterface, cls)] calculateDependency (Right (CSTImplementation, cls)) = @@ -300,7 +295,6 @@ calculateDependency (Right (CSTImplementation, cls)) = (dsNonParents <> dsParents) in depsSelf <> deps --- | isNotInSamePackageWith :: Either TemplateClass Class -> Either TemplateClass Class -> @@ -317,7 +311,6 @@ isInSamePackageButNotInheritedBy :: isInSamePackageButNotInheritedBy x y = x /= y && not (x `elem` getparents y) && (getPkgName x == getPkgName y) --- | mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class] mkModuleDepCpp y@(Right c) = let fs = class_funcs c @@ -352,7 +345,6 @@ mkTopLevelDep (TLTemplate f) = mkTags (Right cls) = fmap (Right . (,cls)) [CSTRawType, CSTCast, CSTInterface] in concatMap mkTags allDeps --- | mkClassModule :: (ModuleUnit -> ModuleUnitImports) -> [(String, [String])] -> @@ -369,12 +361,10 @@ mkClassModule getImports extra c = cmExtraImport = fromMaybe [] (lookup (class_name c) extra) } --- | findModuleUnitImports :: ModuleUnitMap -> ModuleUnit -> ModuleUnitImports findModuleUnitImports m u = fromMaybe emptyModuleUnitImports (HM.lookup u (unModuleUnitMap m)) --- | mkTCM :: TemplateClassImportHeader -> TemplateClassModule @@ -382,7 +372,6 @@ mkTCM tcih = let t = tcihTClass tcih in TCM (getTClassModuleBase t) tcih --- | mkPackageConfig :: -- | (package name,getImports) (CabalName, ModuleUnit -> ModuleUnitImports) -> @@ -408,23 +397,20 @@ mkPackageConfig (pkgname, getImports) (cs, fs, ts, extra) acincs acsrcs = pcfg_additional_c_srcs = acsrcs } --- | mkPkgHeaderFileName :: Class -> HeaderName mkPkgHeaderFileName c = HdrName ( (cabal_cheaderprefix . class_cabal) c <> fst (hsClassName c) - <.> "h" + <.> "h" ) --- | mkPkgCppFileName :: Class -> String mkPkgCppFileName c = (cabal_cheaderprefix . class_cabal) c <> fst (hsClassName c) - <.> "cpp" + <.> "cpp" --- | mkPkgIncludeHeadersInH :: Class -> [HeaderName] mkPkgIncludeHeadersInH c = let pkgname = (cabal_pkgname . class_cabal) c @@ -432,11 +418,9 @@ mkPkgIncludeHeadersInH c = extheaders = L.nub . map ((<> "Type.h") . unCabalName . getPkgName) $ extclasses in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders --- | mkPkgIncludeHeadersInCPP :: Class -> [HeaderName] mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . rights . mkModuleDepCpp . Right --- | mkCIH :: -- | (mk namespace and include headers) (ModuleUnit -> ModuleUnitImports) -> diff --git a/fficxx/src/FFICXX/Generate/Name.hs b/fficxx/src/FFICXX/Generate/Name.hs index 5933e325..6e443914 100644 --- a/fficxx/src/FFICXX/Generate/Name.hs +++ b/fficxx/src/FFICXX/Generate/Name.hs @@ -93,7 +93,6 @@ aliasedFuncName c f = Static _ str _ a -> fromMaybe (nonvirtualName c str) a Destructor a -> fromMaybe destructorName a --- | hsTmplFuncName :: TemplateClass -> TemplateFunction -> String hsTmplFuncName t f = case f of @@ -102,7 +101,6 @@ hsTmplFuncName t f = TFunDelete -> "delete" <> tclass_name t TFunOp {tfun_name} -> tfun_name --- | hsTmplFuncNameTH :: TemplateClass -> TemplateFunction -> String hsTmplFuncNameTH t f = "t_" <> hsTmplFuncName t f @@ -128,7 +126,6 @@ cppTmplFuncName f = TFunDelete -> "delete" TFunOp {tfun_name} -> tfun_name --- | accessorName :: Class -> Variable -> Accessor -> String accessorName c v a = nonvirtualName c (arg_name (unVariable v)) @@ -137,20 +134,16 @@ accessorName c v a = Getter -> "get" Setter -> "set" --- | hscAccessorName :: Class -> Variable -> Accessor -> String hscAccessorName c v a = "c_" <> toLowers (accessorName c v a) --- | tmplAccessorName :: Variable -> Accessor -> String tmplAccessorName (Variable (Arg _ n)) a = n <> "_" <> case a of Getter -> "get"; Setter -> "set" --- | cppStaticName :: Class -> Function -> String cppStaticName c f = class_name c <> "::" <> func_name f --- | cppFuncName :: Class -> Function -> String cppFuncName c f = case f of Constructor _ _ -> "new" diff --git a/fficxx/src/FFICXX/Generate/Util.hs b/fficxx/src/FFICXX/Generate/Util.hs index 790331af..79e82885 100644 --- a/fficxx/src/FFICXX/Generate/Util.hs +++ b/fficxx/src/FFICXX/Generate/Util.hs @@ -70,8 +70,8 @@ intercalateWith f mapper x intercalateWithM :: (Monad m) => (String -> String -> String) -> (a -> m String) -> [a] -> m String intercalateWithM f mapper x | not (null x) = do - ms <- mapM mapper x - return (foldl1 f ms) + ms <- mapM mapper x + return (foldl1 f ms) | otherwise = return "" -- TODO: deprecate this and use contextT diff --git a/flake.lock b/flake.lock index d8542d3f..80892097 100644 --- a/flake.lock +++ b/flake.lock @@ -17,11 +17,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1671220433, - "narHash": "sha256-j+sC1XLEwEHUgMdu4FuSWedlO/BMC4gWUQ6hvzRCWrs=", + "lastModified": 1690839047, + "narHash": "sha256-2V+JIN4z7JQXGQw+Qurq6OwlAAPrBj8ju5/F48Iryho=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "093ec6f77bf9a3de6421952d116ea05c9d80f6e5", + "rev": "de72df367566658cef90fecade0255e5259ad740", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 6e3ca8db..381350ca 100644 --- a/flake.nix +++ b/flake.nix @@ -70,7 +70,7 @@ ''; }; - supportedCompilers = [ "ghc902" "ghc924" "ghc942" ]; + supportedCompilers = [ "ghc927" "ghc945" "ghc962" ]; in { packages = pkgs.lib.genAttrs supportedCompilers (compiler: hpkgsFor compiler); From cce2332593f6d5e65646fde757f46e0e572066c4 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Tue, 8 Aug 2023 13:02:17 -0700 Subject: [PATCH 02/19] Start migrating to direct GHC API use and ghc-exactprint (#212) The simplest HsProxy is migrated. For the time being, haskell-src-exts and ghc+ghc-exactprint will coexist and haskell-src-exts will be faded away. * prepare for ghc-exactprint migration. use only Util.HaskellSrcExts functions except types. * explicit export * make proxy-test generatable (for temporary tests for ghc-exactprint codegen) * first try to generate code using ghc-exactprint * finally print as desired. * success in LANGUAGE pragma printing * mkImport implementation * mkFun, mkFunSig * further mkBind1 * correct indentation doE and handling empty list * remove all s1 * con, inapp, op, par, strE * ormolu format fix * ghc945 -> ghc962 in CI --- .github/workflows/build.yml | 2 +- examples/proxy/Gen.hs | 55 +- examples/proxy/cabal.project | 6 + experiments/ghc-exactprint.hs | 14 + experiments/sample.hs | 10 + fficxx/LICENSE | 2 +- fficxx/fficxx.cabal | 14 +- fficxx/src/FFICXX/Generate/Builder.hs | 13 +- fficxx/src/FFICXX/Generate/Code/HsCast.hs | 6 +- fficxx/src/FFICXX/Generate/Code/HsFFI.hs | 2 +- fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs | 9 +- fficxx/src/FFICXX/Generate/Code/HsProxy.hs | 50 +- fficxx/src/FFICXX/Generate/Code/HsTemplate.hs | 18 +- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 11 +- fficxx/src/FFICXX/Generate/ContentMaker.hs | 37 +- fficxx/src/FFICXX/Generate/Util/DepGraph.hs | 4 +- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 884 ++++++++++++++++++ .../FFICXX/Generate/Util/HaskellSrcExts.hs | 116 ++- 18 files changed, 1127 insertions(+), 126 deletions(-) create mode 100644 examples/proxy/cabal.project create mode 100644 experiments/ghc-exactprint.hs create mode 100644 experiments/sample.hs create mode 100644 fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index a8972510..41a46a69 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -20,7 +20,7 @@ jobs: nix build --print-build-logs .#ghc962.fficxx-runtime - name: build fficxx (GHC 9.6.2) run: | - nix build --print-build-logs .#ghc945.fficxx + nix build --print-build-logs .#ghc962.fficxx - name: build stdcxx (GHC 9.6.2) run: | nix build --print-build-logs .#ghc962.stdcxx diff --git a/examples/proxy/Gen.hs b/examples/proxy/Gen.hs index b722d068..08ed0736 100644 --- a/examples/proxy/Gen.hs +++ b/examples/proxy/Gen.hs @@ -45,7 +45,8 @@ import FFICXX.Generate.Type.Class Class (..), Function (..), ProtectedMethod (..), - TopLevelFunction (..), + TLOrdinary (..), + TopLevel (..), Variable (..), ) import FFICXX.Generate.Type.Config @@ -69,7 +70,7 @@ stdcxx_cabal :: Cabal stdcxx_cabal = Cabal { cabal_pkgname = CabalName "stdcxx", - cabal_version = "0.7.0.1", + cabal_version = "0.8", cabal_cheaderprefix = "STD", cabal_moduleprefix = "STD", cabal_additional_c_incs = [], @@ -98,54 +99,6 @@ deletable = class_tmpl_funcs = [] } --- import from stdcxx -string :: Class -string = - Class - stdcxx_cabal - "string" - [deletable] - mempty - (Just (ClassAlias {caHaskellName = "CppString", caFFIName = "string"})) - [ Constructor [cstring "p"] Nothing, - NonVirtual cstring_ "c_str" [] Nothing, - NonVirtual (cppclassref_ string) "append" [cppclassref string "str"] Nothing, - NonVirtual (cppclassref_ string) "erase" [] Nothing - ] - [] - [] - False - -t_vector :: TemplateClass -t_vector = - TmplCls - stdcxx_cabal - "Vector" - "std::vector" - ["tp1"] - [ TFunNew [] Nothing, - TFun void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"] Nothing, - TFun void_ "pop_back" "pop_back" [] Nothing, - TFun (TemplateParam "tp1") "at" "at" [int "n"] Nothing, - TFun int_ "size" "size" [] Nothing, - TFunDelete - ] - -t_unique_ptr :: TemplateClass -t_unique_ptr = - TmplCls - stdcxx_cabal - "UniquePtr" - "std::unique_ptr" - ["tp1"] - [ TFunNew [] (Just "newUniquePtr0"), - TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing, - TFun (TemplateParamPointer "tp1") "get" "get" [] Nothing, - TFun (TemplateParamPointer "tp1") "release" "release" [] Nothing, - TFun void_ "reset" "reset" [] Nothing, - TFunDelete - ] - -- ------------------------------------------------------------------- -- proxy-test -- ------------------------------------------------------------------- @@ -218,7 +171,7 @@ main = do let tmpldir = if length args == 1 then args !! 0 - else "../template" + else "./template" cwd <- getCurrentDirectory diff --git a/examples/proxy/cabal.project b/examples/proxy/cabal.project new file mode 100644 index 00000000..70a9bbb9 --- /dev/null +++ b/examples/proxy/cabal.project @@ -0,0 +1,6 @@ +packages: + ../../fficxx/ + ../../fficxx-runtime/ +optional-packages: + ./stdcxx/ + ./proxy-test/ diff --git a/experiments/ghc-exactprint.hs b/experiments/ghc-exactprint.hs new file mode 100644 index 00000000..57157732 --- /dev/null +++ b/experiments/ghc-exactprint.hs @@ -0,0 +1,14 @@ +module Main where + +import Language.Haskell.GHC.ExactPrint + ( makeDeltaAst, + parseModule, + showAst, + ) + +main :: IO () +main = do + e <- parseModule "/nix/store/1dccaqdx3v2acc4zk5cnln14jf5q7h04-ghc-9.6.2-with-packages/lib/ghc-9.6.2/lib" "./sample.hs" + case e of + Left msg -> print "error" -- print msg + Right parsed -> putStrLn (showAst (makeDeltaAst parsed)) diff --git a/experiments/sample.hs b/experiments/sample.hs new file mode 100644 index 00000000..858fee00 --- /dev/null +++ b/experiments/sample.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -w #-} + +module MyModule where + +data K = K Int + +test :: IO () +test = do + addModFinalizer (addForeignSource LangCxx "\n#include \"test\"") diff --git a/fficxx/LICENSE b/fficxx/LICENSE index 2165943d..330935ea 100644 --- a/fficxx/LICENSE +++ b/fficxx/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011-2022, Ian-Woo Kim. All rights reserved. +Copyright 2011-2023, Ian-Woo Kim. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 757b8a27..0c155ef6 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -1,4 +1,4 @@ -Cabal-Version: 3.0 +Cabal-Version: 3.6 Name: fficxx Version: 0.8.0.0 Synopsis: Automatic C++ binding generation @@ -31,7 +31,6 @@ Library , fficxx-runtime , filepath>1 , hashable - , haskell-src-exts >= 1.22 , lens > 3 , mtl>2 , process @@ -42,6 +41,16 @@ Library , template-haskell , text , unordered-containers + , haskell-src-exts + if impl (ghc >= 9.6) + Build-Depends: + ghc >= 9.6, + ghc-exactprint >= 1.7.0.0 + else + Build-Depends: + ghc, + ghc-exactprint + Exposed-Modules: FFICXX.Generate.Builder FFICXX.Generate.Config @@ -60,6 +69,7 @@ Library FFICXX.Generate.QQ.Verbatim FFICXX.Generate.Util FFICXX.Generate.Util.DepGraph + FFICXX.Generate.Util.GHCExactPrint FFICXX.Generate.Util.HaskellSrcExts FFICXX.Generate.Type.Annotate FFICXX.Generate.Type.Cabal diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 3f01c3d8..3cc7876c 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -40,8 +40,10 @@ import FFICXX.Generate.Type.Module TopLevelImportHeader (..), ) import FFICXX.Generate.Util (moduleDirFile) +import FFICXX.Generate.Util.GHCExactPrint (exactPrint) +import FFICXX.Generate.Util.HaskellSrcExts (prettyPrint) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) -import Language.Haskell.Exts.Pretty (prettyPrint) +import qualified Language.Haskell.GHC.ExactPrint as Exact import System.Directory ( copyFile, createDirectoryIfMissing, @@ -163,8 +165,13 @@ simpleBuilder cfg sbc = do -- putStrLn "Generating Proxy.hs" for_ mods $ \m -> - when (hasProxy . cihClass . cmCIH $ m) $ - gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (C.buildProxyHs m)) + when (hasProxy . cihClass . cmCIH $ m) $ do + let x = C.buildProxyHs m + putStrLn (Exact.showAst x) + putStrLn "-------" + putStrLn (exactPrint (C.buildProxyHs m)) + putStrLn "-------" + gen (cmModule m <.> "Proxy" <.> "hs") (exactPrint (C.buildProxyHs m)) -- putStrLn "Generating Template.hs" for_ tcms $ \m -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs index 6c0c140d..c0ce209c 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCast.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCast.hs @@ -4,7 +4,8 @@ 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, + ( app, + classA, cxEmpty, cxTuple, insDecl, @@ -18,8 +19,7 @@ import FFICXX.Generate.Util.HaskellSrcExts tycon, unqual, ) -import Language.Haskell.Exts.Build (app) -import Language.Haskell.Exts.Syntax (Decl (..), InstDecl (..)) +import Language.Haskell.Exts.Syntax (Decl, InstDecl) ----- diff --git a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs index 035daa23..f6963651 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs @@ -42,7 +42,7 @@ import FFICXX.Generate.Type.Module import FFICXX.Generate.Util (toLowers) import FFICXX.Generate.Util.HaskellSrcExts (mkForImpCcall, mkImport) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) -import Language.Haskell.Exts.Syntax (Decl (..), ImportDecl (..)) +import Language.Haskell.Exts.Syntax (Decl, ImportDecl) import System.FilePath ((<.>)) genHsFFI :: ClassImportHeader -> [Decl ()] diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs index 28b294ab..14630fd1 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -105,10 +105,9 @@ import FFICXX.Generate.Util.HaskellSrcExts ) import Language.Haskell.Exts.Build (app, letE, name, pApp) import Language.Haskell.Exts.Syntax - ( Context (CxTuple), - Decl (..), - ExportSpec (..), - ImportDecl (..), + ( Decl, + ExportSpec, + ImportDecl, ) import System.FilePath ((<.>)) @@ -120,7 +119,7 @@ genHsFrontDecl isHsBoot c = do -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body -- for hs-boot, we only have instance head. - cdecl' = mkClass (CxTuple () []) (typeclassName c) [mkTBind "a"] [] + cdecl' = mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] [] sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c if isHsBoot diff --git a/fficxx/src/FFICXX/Generate/Code/HsProxy.hs b/fficxx/src/FFICXX/Generate/Code/HsProxy.hs index f61e2604..fbc79932 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsProxy.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsProxy.hs @@ -3,45 +3,53 @@ module FFICXX.Generate.Code.HsProxy where import qualified Data.List as L (foldr1) --- - -import FFICXX.Generate.Util.HaskellSrcExts - ( con, +import FFICXX.Generate.Util.GHCExactPrint + ( app, + con, + doE, inapp, + listE, + mkBodyStmt, mkFun, mkVar, op, - qualifier, + par, + strE, tyapp, tycon, tylist, ) import qualified FFICXX.Runtime.CodeGen.Cxx as R -import Language.Haskell.Exts.Build (app, doE, listE, qualStmt, strE) -import Language.Haskell.Exts.Syntax (Decl (..)) +import GHC.Hs.Extension + ( GhcPs, + ) +import Language.Haskell.Syntax.Decls (HsDecl) -genProxyInstance :: [Decl ()] -genProxyInstance = - mkFun fname sig [] rhs Nothing +genProxyInstance :: [HsDecl GhcPs] +genProxyInstance = mkFun fname sig [] rhs Nothing where fname = "genImplProxy" - v = mkVar sig = tycon "Q" `tyapp` tylist (tycon "Dec") - rhs = doE [foreignSrcStmt, qualStmt retstmt] + rhs = doE [foreignSrcStmt, retstmt] + + v = mkVar + retstmt = mkBodyStmt (v "pure" `app` listE []) + foreignSrcStmt = - qualifier $ + mkBodyStmt $ (v "addModFinalizer") - `app` ( v "addForeignSource" - `app` con "LangCxx" - `app` ( L.foldr1 - (\x y -> inapp x (op "++") y) - [includeStatic] - ) - ) + `app` par + ( v "addForeignSource" + `app` con "LangCxx" + `app` par + ( L.foldr1 + (\x y -> inapp x (op "++") y) + [includeStatic] + ) + ) where includeStatic = strE $ concatMap (<> "\n") [R.renderCMacro (R.Include "MacroPatternMatch.h")] - retstmt = v "pure" `app` listE [] diff --git a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs index 01aee805..4eecdc4b 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs @@ -79,6 +79,7 @@ import FFICXX.Generate.Util.HaskellSrcExts qualifier, tyPtr, tySplice, + tyTupleBoxed, tyapp, tycon, tyfun, @@ -106,7 +107,10 @@ import Language.Haskell.Exts.Build tuple, wildcard, ) -import Language.Haskell.Exts.Syntax (Boxed (Boxed), Decl (..), ImportDecl (..), Type (TyTuple)) +import Language.Haskell.Exts.Syntax + ( Decl, + ImportDecl, + ) ------------------------------ -- Template member function -- @@ -127,7 +131,7 @@ genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) itps = zip ([1 ..] :: [Int]) (tmf_params f) tvars = map (\(i, _) -> "typ" ++ show i) itps nparams = length itps - tparams = if nparams == 1 then tycon "Type" else TyTuple () Boxed (replicate nparams (tycon "Type")) + tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] lit' = strE (hsTemplateMemberFunctionName c f <> "_") @@ -165,7 +169,7 @@ genTMFInstance cih f = v = mkVar sig = tycon "IsCPrimitive" - `tyfun` TyTuple () Boxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"] + `tyfun` tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"] `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec")) rhs = doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, letStmt lststmt, qualStmt retstmt] suffixstmt = letStmt [pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param")] @@ -278,7 +282,7 @@ genTmplImplementation t = itps = zip ([1 ..] :: [Int]) (tclass_params t) tvars = map (\(i, _) -> "typ" ++ show i) itps nparams = length itps - tparams = if nparams == 1 then tycon "Type" else TyTuple () Boxed (replicate nparams (tycon "Type")) + tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] prefix = tclass_name t @@ -340,7 +344,7 @@ genTmplInstance tcih = [tycon "IsCPrimitive"] ++ replicate nparams - (TyTuple () Boxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) + (tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) ++ [tycon "Q" `tyapp` tylist (tycon "Dec")] nfs = zip ([1 ..] :: [Int]) fs nvfs = zip ([1 ..] :: [Int]) vfs @@ -519,7 +523,7 @@ genTLTemplateImplementation t = itps = zip ([1 ..] :: [Int]) (topleveltfunc_params t) tvars = map (\(i, _) -> "typ" ++ show i) itps nparams = length itps - tparams = if nparams == 1 then tycon "Type" else TyTuple () Boxed (replicate nparams (tycon "Type")) + tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] prefix = "TL" @@ -578,7 +582,7 @@ genTLTemplateInstance tih t = [tycon "IsCPrimitive"] ++ replicate nparams - (TyTuple () Boxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) + (tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) ++ [tycon "Q" `tyapp` tylist (tycon "Dec")] -- nvfs = zip ([1..] :: [Int]) vfs diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 1d9bb18e..d7cfda1a 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -41,6 +41,7 @@ import FFICXX.Generate.Util.HaskellSrcExts mkTVar, mkVar, parenSplice, + tyForall, tyPtr, tySplice, tyapp, @@ -51,7 +52,11 @@ import FFICXX.Generate.Util.HaskellSrcExts ) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) -import Language.Haskell.Exts.Syntax (Asst (..), Context, Type (..)) +import Language.Haskell.Exts.Syntax + ( Asst, + Context, + Type, + ) data CFunSig = CFunSig { cArgTypes :: [Arg], @@ -869,7 +874,7 @@ functionSignature c f = | isVirtualFunc f = (mkTVar "a" :) | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :) | otherwise = id - in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) + in tyForall Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) functionSignatureT :: TemplateClass -> TemplateFunction -> Type () functionSignatureT t TFun {..} = @@ -948,7 +953,7 @@ accessorSignature c v accessor = HsFunSig typs assts = extractArgRetTypes (Just c) False csig ctxt = cxTuple assts arg0 = (mkTVar (fst (hsClassName c)) :) - in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) + in tyForall Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) -- | this is for FFI type. hsFFIFuncTyp :: Maybe (Selfness, Class) -> CFunSig -> Type () diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 9afb8d6c..4a0d9a04 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -106,8 +106,11 @@ import FFICXX.Generate.Type.PackageInterface PackageName (..), ) import FFICXX.Generate.Util (firstUpper) +import qualified FFICXX.Generate.Util.GHCExactPrint as Ex import FFICXX.Generate.Util.HaskellSrcExts - ( emodule, + ( eWildCard, + emodule, + ethingwith, evar, lang, mkImport, @@ -117,12 +120,12 @@ import FFICXX.Generate.Util.HaskellSrcExts ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R +import GHC.Hs.Extension (GhcPs) import Language.Haskell.Exts.Syntax - ( Decl (..), - EWildcard (EWildcard), - ExportSpec (EThingWith), - Module (..), + ( Decl, + Module, ) +import Language.Haskell.Syntax (HsModule) import System.FilePath ((<.>), ()) srcDir :: FilePath -> FilePath @@ -515,21 +518,19 @@ buildImplementationHs amap m = <> concatMap genHsFrontInstVariables classes <> genTemplateMemberFunctions (cmCIH m) -buildProxyHs :: ClassModule -> Module () +buildProxyHs :: ClassModule -> HsModule GhcPs buildProxyHs m = - mkModule + Ex.mkModule (cmModule m <.> "Proxy") - [ lang - [ "FlexibleInstances", - "OverloadedStrings", - "TemplateHaskell" - ] + [ "FlexibleInstances", + "OverloadedStrings", + "TemplateHaskell" ] - [ mkImport "Foreign.Ptr", - mkImport "FFICXX.Runtime.Cast", - mkImport "Language.Haskell.TH", - mkImport "Language.Haskell.TH.Syntax", - mkImport "FFICXX.Runtime.CodeGen.Cxx" + [ Ex.mkImport "Foreign.Ptr", + Ex.mkImport "FFICXX.Runtime.Cast", + Ex.mkImport "Language.Haskell.TH", + Ex.mkImport "Language.Haskell.TH.Syntax", + Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx" ] body where @@ -658,7 +659,7 @@ buildTopLevelTemplateHs modname tih = ] pkgExports = map - ( (\n -> EThingWith () (EWildcard () 1) n []) + ( (\n -> ethingwith (eWildCard 1) n []) . unqual . firstUpper . hsFrontNameForTopLevel diff --git a/fficxx/src/FFICXX/Generate/Util/DepGraph.hs b/fficxx/src/FFICXX/Generate/Util/DepGraph.hs index b6a44524..851aa6fd 100644 --- a/fficxx/src/FFICXX/Generate/Util/DepGraph.hs +++ b/fficxx/src/FFICXX/Generate/Util/DepGraph.hs @@ -11,10 +11,8 @@ import FFICXX.Generate.Type.Class (TopLevel (..)) import FFICXX.Generate.Type.Module (UClass) import Text.Dot (Dot, NodeId, attribute, node, showDot, (.->.)) -src, box, diamond :: String -> Dot NodeId -src label = node $ [("shape", "none"), ("label", label)] +box :: String -> Dot NodeId box label = node $ [("shape", "box"), ("style", "rounded"), ("label", label)] -diamond label = node $ [("shape", "diamond"), ("label", label), ("fontsize", "10")] -- | Draw dependency graph of modules in graphviz dot format. drawDepGraph :: diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs new file mode 100644 index 00000000..258dccf5 --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -0,0 +1,884 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module FFICXX.Generate.Util.GHCExactPrint + ( -- * module + mkModule, + + -- * import + mkImport, + + -- * names + unqual, + + -- * types + mkTVar, + tycon, + tyapp, + tylist, + + -- * function + mkFun, + mkFunSig, + mkBind1, + + -- * expr + app, + con, + doE, + inapp, + listE, + mkVar, + op, + par, + strE, + + -- * stmt + mkBodyStmt, + {- app', + tyfun, + unit_tycon, + conDecl, + qualConDecl, + recDecl, + lit, + mkTVar, + mkPVar, + mkIVar, + mkPVarSig, + pbind, + pbind_, + mkTBind, + mkClass, + dhead, + mkDeclHead, + mkInstance, + mkData, + mkNewtype, + mkForImpCcall, + mkModuleE, + mkImportExp, + mkImportSrc, + lang, + dot, + tyForall, + tyParen, + tyPtr, + tyForeignPtr, + classA, + cxEmpty, + cxTuple, + tySplice, + tyTupleBoxed, + parenSplice, + bracketExp, + typeBracket, + mkDeriving, + irule, + ihcon, + evar, + eabs, + ethingwith, + ethingall, + emodule, + nonamespace, + insType, + insDecl, + generator, + qualifier, + clsDecl, + unkindedVar, + if_, + urhs, + match, + eWildCard, -} + + -- * utility + exactPrint, + ) +where + +import Data.List (foldl') +import Data.Maybe (maybeToList) +import Data.String (IsString (fromString)) +import GHC.Hs + ( AnnsModule (..), + GrhsAnn (..), + XModulePs (..), + ) +import GHC.Hs.Binds + ( AnnSig (..), + ) +import GHC.Hs.Extension + ( GhcPs, + ) +import GHC.Hs.ImpExp + ( XImportDeclPass (..), + ) +import GHC.Parser.Annotation + ( AddEpAnn (..), + Anchor (..), + AnchorOperation (..), + AnnKeywordId (..), + AnnList (..), + AnnListItem (..), + AnnParen (..), + DeltaPos (..), + EpAnn (..), + EpaComment (..), + EpaCommentTok (EpaLineComment), + EpaLocation (..), + NameAnn (..), + NoEpAnns (..), + ParenType (AnnParensSquare), + SrcAnn, + SrcSpanAnn' (SrcSpanAnn), + SrcSpanAnnA, + TokenLocation (..), + emptyComments, + noAnn, + noSrcSpanA, + spanAsAnchor, + ) +import GHC.Types.Basic + ( Origin (FromSource), + ) +import GHC.Types.Fixity + ( LexicalFixity (Prefix), + ) +import GHC.Types.Name.Occurrence + ( OccName, + mkOccName, + mkTyVarOcc, + mkVarOcc, + ) +import GHC.Types.Name.Reader + ( RdrName (Unqual), + ) +import GHC.Types.PkgQual + ( RawPkgQual (..), + ) +import GHC.Types.SourceText + ( SourceText (..), + ) +import GHC.Types.SrcLoc + ( GenLocated (L), + RealSrcSpan, + SrcSpan (..), + mkSrcLoc, + mkSrcSpan, + srcLocSpan, + ) +import qualified Language.Haskell.GHC.ExactPrint as Exact +import Language.Haskell.Syntax + ( Anno, + ExprLStmt, + GRHS (..), + GRHSs (..), + HsBind (..), + HsBindLR (..), + HsDecl (..), + HsDoFlavour (..), + HsExpr (..), + HsLit (..), + HsLocalBinds, + HsLocalBindsLR (..), + HsMatchContext (FunRhs), + HsModule (..), + HsOuterTyVarBndrs (HsOuterImplicit), + HsSigType (HsSig), + HsToken (..), + HsType (..), + HsWildCardBndrs (HsWC), + ImportDecl (..), + ImportDeclQualifiedStyle (..), + IsBootInterface (..), + LHsExpr, + LayoutInfo (..), + Match (..), + MatchGroup (..), + ModuleName (..), + Pat (..), + PromotionFlag (..), + Sig (TypeSig), + StmtLR (..), + noExtField, + ) +import Language.Haskell.Syntax.Basic + ( SrcStrictness (NoSrcStrict), + ) + +mkRelAnchor :: Int -> Anchor +mkRelAnchor nLines = + let a' = spanAsAnchor defSrcSpan + in if + | nLines < -1 -> error "mkRelAnchor: cannot go backward further" + | nLines == -1 -> a' {anchor_op = MovedAnchor (SameLine 0)} + | nLines == 0 -> a' {anchor_op = MovedAnchor (SameLine 1)} + | nLines > 0 -> a' {anchor_op = MovedAnchor (DifferentLine nLines 0)} + +mkRelEpAnn :: Int -> ann -> EpAnn ann +mkRelEpAnn nLines ann = EpAnn (mkRelAnchor nLines) ann emptyComments + +mkRelSrcSpanAnn :: Int -> ann -> SrcAnn ann +mkRelSrcSpanAnn nLines ann = + SrcSpanAnn (mkRelEpAnn nLines ann) defSrcSpan + +defSrcSpan :: SrcSpan +defSrcSpan = spn + where + sloc = mkSrcLoc "test" 1 1 + spn = srcLocSpan sloc + +defRealSrcSpan :: RealSrcSpan +defRealSrcSpan = rspn + where + RealSrcSpan rspn _ = defSrcSpan + +paragraphLines :: [a] -> [GenLocated SrcSpanAnnA a] +paragraphLines zs = + case zs of + x : xs -> + let x' = L (mkRelSrcSpanAnn 2 (AnnListItem [])) x + xs' = fmap (L (mkRelSrcSpanAnn 1 (AnnListItem []))) xs + in x' : xs' + [] -> [] + +-- | can place the group of items with arbitrary indentation. +paragraphLines' :: DeltaPos -> [a] -> [GenLocated SrcSpanAnnA a] +paragraphLines' delta zs = + case zs of + x : xs -> + let a = spanAsAnchor defSrcSpan + a' = a {anchor_op = MovedAnchor delta} + ann' = SrcSpanAnn (EpAnn a' (AnnListItem []) emptyComments) defSrcSpan + x' = L ann' x + xs' = fmap (L (mkRelSrcSpanAnn 1 (AnnListItem []))) xs + in x' : xs' + [] -> [] + +noAnnList :: AnnList +noAnnList = AnnList Nothing Nothing Nothing [] [] + +noAnnListItem :: AnnListItem +noAnnListItem = AnnListItem [] + +mkL :: Int -> a -> GenLocated SrcSpanAnnA a +mkL nLines = L (mkRelSrcSpanAnn nLines noAnnListItem) + +-- +-- Modules +-- + +mkModule :: + -- | Module name + String -> + -- | Pragmas + [String] -> + [ImportDecl GhcPs] -> + [HsDecl GhcPs] -> + HsModule GhcPs +mkModule name pragmas idecls decls = + HsModule + { hsmodExt = + XModulePs + { hsmodAnn = mkRelEpAnn (-1) a1, + hsmodLayout = VirtualBraces 1, + hsmodDeprecMessage = Nothing, + hsmodHaddockModHeader = Nothing + }, + hsmodName = Just (L (mkRelSrcSpanAnn 0 noAnnListItem) modName), + hsmodExports = Nothing, + hsmodImports = paragraphLines idecls, + hsmodDecls = paragraphLines decls + } + where + modName = ModuleName (fromString name) + pragmaComments = + let ls = + fmap + ( \p -> + let a = mkRelAnchor 1 + str = "{-# LANGUAGE " <> p <> " #-}" + c = EpaComment (EpaLineComment str) defRealSrcSpan + in L a c + ) + pragmas + in ls + a1 = + AnnsModule + [ AddEpAnn AnnModule (EpaDelta (DifferentLine 2 0) pragmaComments), + AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) + ] + (AnnList Nothing Nothing Nothing [] []) + +-- +-- Imports +-- + +mkImport :: + -- | Module name + String -> + ImportDecl GhcPs +mkImport name = + ImportDecl + { ideclExt = XImportDeclPass noAnn NoSourceText False, + ideclName = L (mkRelSrcSpanAnn 0 (AnnListItem [])) modName, + ideclPkgQual = NoRawPkgQual, + ideclSource = NotBoot, + ideclSafe = False, + ideclQualified = NotQualified, + ideclAs = Nothing, + ideclImportList = Nothing + } + where + modName = ModuleName (fromString name) + +-- +-- names +-- + +unqual :: OccName -> RdrName +unqual = Unqual + +-- +-- types +-- + +tycon :: String -> HsType GhcPs +tycon name = + HsTyVar + noAnn + NotPromoted + (L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) (unqual (mkTyVarOcc name))) + +-- TODO: deprecate this later +mkTVar :: String -> HsType GhcPs +mkTVar = tycon + +tyapp :: HsType GhcPs -> HsType GhcPs -> HsType GhcPs +tyapp x y = + HsAppTy noExtField lx ly + where + lx = mkL (-1) x + ly = mkL 0 y + +tylist :: HsType GhcPs -> HsType GhcPs +tylist x = + HsListTy (mkRelEpAnn (-1) ann) lx + where + ann = + AnnParen + { ap_adornment = AnnParensSquare, + ap_open = EpaDelta (SameLine 0) [], + ap_close = EpaDelta (SameLine 0) [] + } + lx = mkL (-1) x + +-- +-- Function +-- + +mkFun :: + -- | function name + String -> + -- | function type + HsType GhcPs -> + -- | arg pattern + [Pat GhcPs] -> + -- | RHS + HsExpr GhcPs -> + -- | where + Maybe (HsLocalBinds GhcPs) -> + -- | decls + [HsDecl GhcPs] +mkFun fname typ pats rhs mbinds = + [ mkFunSig fname typ, + mkBind1 fname pats rhs mbinds + ] + +mkFunSig :: + -- | function name + String -> + HsType GhcPs -> + HsDecl GhcPs +mkFunSig fname typ = + SigD noExtField (TypeSig ann [lid] bndr) + where + ann = + mkRelEpAnn (-1) (AnnSig (AddEpAnn AnnDcolon (EpaDelta (SameLine 1) [])) []) + + id' = unqual (mkVarOcc fname) + lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' + bndr = HsWC noExtField (L (mkRelSrcSpanAnn 0 (AnnListItem [])) hsSigType) + hsSigType = + HsSig + noExtField + (HsOuterImplicit noExtField) + (mkL (-1) typ) + +mkBind1 :: + String -> + [Pat GhcPs] -> + HsExpr GhcPs -> + Maybe (HsLocalBinds GhcPs) -> + HsDecl GhcPs +mkBind1 fname pats rhs mbinds = + ValD noExtField (FunBind noExtField lid payload) + where + id' = unqual (mkVarOcc fname) + lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' + + lpats = [] -- fmap (L ) pats + lrhs = mkL (-1) rhs + glrhs = + let ann = + mkRelEpAnn + (-1) + (GrhsAnn Nothing (AddEpAnn AnnEqual (EpaDelta (SameLine 1) []))) + in GRHS ann [] (lrhs) + lglrhs = L (mkRelSrcSpanAnn (-1) NoEpAnns) glrhs + match = + Match + { m_ext = mkRelEpAnn (-1) [], + m_ctxt = FunRhs lid Prefix NoSrcStrict, + m_pats = lpats, + m_grhss = + GRHSs + { grhssExt = emptyComments, + grhssGRHSs = [lglrhs], + grhssLocalBinds = EmptyLocalBinds noExtField + } + } + lmatch = mkL (-1) match + payload = MG FromSource (L (mkRelSrcSpanAnn (-1) noAnnList) [lmatch]) + +-- +-- Expr +-- + +app :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs +app x y = + HsApp (mkRelEpAnn (-1) NoEpAnns) lx ly + where + lx = mkL (-1) x + ly = mkL 0 y + +-- NOTE: in ghc API, no difference between constructor and variable +con :: String -> HsExpr GhcPs +con = mkVar + +doE :: [StmtLR GhcPs GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs +doE stmts = + HsDo + (mkRelEpAnn (-1) annDo) + (DoExpr Nothing) + llstmts + where + annDo = + AnnList + Nothing + Nothing + Nothing + [AddEpAnn AnnDo (EpaDelta (SameLine 1) [])] + [] + lstmts = + paragraphLines' (DifferentLine 1 2) stmts + llstmts = + let ann = mkRelSrcSpanAnn (-1) noAnnList + in L ann lstmts + +inapp :: + -- | left arg + HsExpr GhcPs -> + -- | operator + HsExpr GhcPs -> + -- | right arg + HsExpr GhcPs -> + HsExpr GhcPs +inapp x o y = + OpApp ann lx lo ly + where + ann = mkRelEpAnn (-1) [] + lx = mkL (-1) x + lo = mkL (-1) o + ly = mkL (-1) y + +listE :: [HsExpr GhcPs] -> HsExpr GhcPs +listE itms = + case itms of + -- NOTE: More correct way is to use GHC.Builtin.Names, but for codegen, this is enough. + [] -> mkVar "[]" + _ : _ -> + let ann = + AnnList + Nothing + Nothing + Nothing + [ AddEpAnn AnnOpenS (EpaDelta (SameLine 0) []), + AddEpAnn AnnCloseS (EpaDelta (SameLine 0) []) + ] + [] + litms = fmap (mkL (-1)) itms + in ExplicitList (mkRelEpAnn (-1) ann) litms + where + +mkVar :: String -> HsExpr GhcPs +mkVar name = + HsVar noExtField lid + where + id' = unqual (mkVarOcc name) + lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' + +op :: String -> HsExpr GhcPs +op = mkVar + +par :: HsExpr GhcPs -> HsExpr GhcPs +par expr = + HsPar ann tokOpen (mkL (-1) expr) tokClose + where + ann = mkRelEpAnn (-1) NoEpAnns + tokOpen = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok + tokClose = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok + +strE :: String -> HsExpr GhcPs +strE str = HsLit ann1 (HsString ann2 (fromString str)) + where + str' = show str + ann1 = mkRelEpAnn (-1) NoEpAnns + ann2 = SourceText str' + +-- +-- Statements +-- + +mkBodyStmt :: HsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkBodyStmt expr = + BodyStmt noExtField body noExtField noExtField + where + body = mkL (-1) expr + +-- +-- utilities +-- + +-- | exact print +exactPrint :: (Exact.ExactPrint ast) => ast -> String +exactPrint = Exact.exactPrint . Exact.makeDeltaAst + +{- +import Language.Haskell.Exts + ( Alt (..), + Asst (TypeA), + Binds, + Bracket (TypeBracket), + CallConv (CCall), + ClassDecl (ClsDecl), + ConDecl + ( ConDecl, + RecDecl + ), + Context + ( CxEmpty, + CxTuple + ), + DataOrNew + ( DataType, + NewType + ), + Decl + ( ClassDecl, + DataDecl, + ForImp, + FunBind, + InstDecl, + PatBind, + TypeSig + ), + DeclHead + ( DHApp, + DHead + ), + Deriving (..), + EWildcard (..), + Exp + ( App, + BracketExp, + Con, + If, + InfixApp, + Lit, + Var + ), + ExportSpec + ( EAbs, + EModuleContents, + EThingWith, + EVar + ), + ExportSpecList (..), + FieldDecl, + ImportDecl (..), + ImportSpec (IVar), + ImportSpecList (..), + InstDecl + ( InsDecl, + InsType + ), + InstHead + ( IHApp, + IHCon + ), + InstRule (IRule), + Literal, + Match (..), + Module (..), + ModuleHead (..), + ModuleName (..), + ModulePragma (LanguagePragma), + Name + ( Ident, + Symbol + ), + Namespace (NoNamespace), + Pat + ( PVar, + PatTypeSig + ), + QName (UnQual), + QOp (QVarOp), + QualConDecl (..), + Rhs (UnGuardedRhs), + Safety (PlayInterruptible), + Splice (ParenSplice), + Stmt + ( Generator, + Qualifier + ), + TyVarBind (UnkindedVar), + Type + ( TyApp, + TyCon, + TyForall, + TyFun, + TyList, + TyParen, + TySplice, + TyTuple, + TyVar + ), + ) -} +-- import qualified Language.Haskell.Exts as LHE +-- import Language.Haskell.Exts.Syntax (CName) + +{- +app :: Exp () -> Exp () -> Exp () +app = LHE.app + +app' :: String -> String -> Exp () +app' x y = App () (mkVar x) (mkVar y) + +unqual :: String -> QName () +unqual = UnQual () . Ident () + +infixl 2 `tyapp` + +tyfun :: Type () -> Type () -> Type () +tyfun = TyFun () + +infixr 2 `tyfun` + +unit_tycon :: Type () +unit_tycon = LHE.unit_tycon () + +conDecl :: String -> [Type ()] -> ConDecl () +conDecl n ys = ConDecl () (Ident () n) ys + +qualConDecl :: + Maybe [TyVarBind ()] -> + Maybe (Context ()) -> + ConDecl () -> + QualConDecl () +qualConDecl = QualConDecl () + +recDecl :: String -> [FieldDecl ()] -> ConDecl () +recDecl n rs = RecDecl () (Ident () n) rs + +lit :: Literal () -> Exp () +lit = Lit () + +mkPVar :: String -> Pat () +mkPVar = PVar () . Ident () + +mkIVar :: String -> ImportSpec () +mkIVar = IVar () . Ident () + +mkPVarSig :: String -> Type () -> Pat () +mkPVarSig n typ = PatTypeSig () (mkPVar n) typ + +pbind :: Pat () -> Exp () -> Maybe (Binds ()) -> Decl () +pbind pat e = PatBind () pat (UnGuardedRhs () e) + +pbind_ :: Pat () -> Exp () -> Decl () +pbind_ p e = pbind p e Nothing + +mkTBind :: String -> TyVarBind () +mkTBind = UnkindedVar () . Ident () + +mkClass :: Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl () +mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds) [] (Just cdecls) + +dhead :: String -> DeclHead () +dhead n = DHead () (Ident () n) + +mkDeclHead :: String -> [TyVarBind ()] -> DeclHead () +mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds + +mkInstance :: Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl () +mkInstance ctxt n typs idecls = InstDecl () Nothing instrule (Just idecls) + where + instrule = IRule () Nothing (Just ctxt) insthead + insthead = foldl' f (IHCon () (unqual n)) typs + where + f acc x = IHApp () acc (tyParen x) + +mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () +mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv) + where + declhead = mkDeclHead n tbinds + +mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () +mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv) + where + declhead = mkDeclHead n tbinds + +mkForImpCcall :: String -> String -> Type () -> Decl () +mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlayInterruptible ())) (Just quote) (Ident () n) typ + +mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module () +mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls + where + mhead = ModuleHead () (ModuleName () n) Nothing (Just eslist) + eslist = ExportSpecList () exps + +mkImportExp :: String -> [String] -> ImportDecl () +mkImportExp m lst = + ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist) + where + islist = ImportSpecList () False (map mkIVar lst) + +mkImportSrc :: String -> ImportDecl () +mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing + +lang :: [String] -> ModulePragma () +lang ns = LanguagePragma () (map (Ident ()) ns) + +dot :: Exp () -> Exp () -> Exp () +x `dot` y = x `app` mkVar "." `app` y + +tyForall :: + Maybe [TyVarBind ()] -> + Maybe (Context ()) -> + Type () -> + Type () +tyForall = TyForall () + +tyParen :: Type () -> Type () +tyParen = TyParen () + +tyPtr :: Type () +tyPtr = tycon "Ptr" + +tyForeignPtr :: Type () +tyForeignPtr = tycon "ForeignPtr" + +classA :: QName () -> [Type ()] -> Asst () +classA n = TypeA () . foldl' tyapp (TyCon () n) + +cxEmpty :: Context () +cxEmpty = CxEmpty () + +cxTuple :: [Asst ()] -> Context () +cxTuple = CxTuple () + +tySplice :: Splice () -> Type () +tySplice = TySplice () + +tyTupleBoxed :: [Type ()] -> Type () +tyTupleBoxed = TyTuple () LHE.Boxed + +parenSplice :: Exp () -> Splice () +parenSplice = ParenSplice () + +bracketExp :: Bracket () -> Exp () +bracketExp = BracketExp () + +typeBracket :: Type () -> Bracket () +typeBracket = TypeBracket () + +mkDeriving :: [InstRule ()] -> Deriving () +mkDeriving = Deriving () Nothing + +irule :: + Maybe [TyVarBind ()] -> + Maybe (Context ()) -> + InstHead () -> + InstRule () +irule = IRule () + +ihcon :: QName () -> InstHead () +ihcon = IHCon () + +evar :: QName () -> ExportSpec () +evar = EVar () + +eabs :: Namespace () -> QName () -> ExportSpec () +eabs = EAbs () + +ethingwith :: + EWildcard () -> + QName () -> + [Language.Haskell.Exts.Syntax.CName ()] -> + ExportSpec () +ethingwith = EThingWith () + +ethingall :: QName () -> ExportSpec () +ethingall q = ethingwith (EWildcard () 0) q [] + +emodule :: String -> ExportSpec () +emodule nm = EModuleContents () (ModuleName () nm) + +nonamespace :: Namespace () +nonamespace = NoNamespace () + +insType :: Type () -> Type () -> InstDecl () +insType = InsType () + +insDecl :: Decl () -> InstDecl () +insDecl = InsDecl () + +generator :: Pat () -> Exp () -> Stmt () +generator = Generator () + +qualifier :: Exp () -> Stmt () +qualifier = Qualifier () + +clsDecl :: Decl () -> ClassDecl () +clsDecl = ClsDecl () + +unkindedVar :: Name () -> TyVarBind () +unkindedVar = UnkindedVar () + +if_ :: Exp () -> Exp () -> Exp () -> Exp () +if_ = If () + +urhs :: Exp () -> Rhs () +urhs = UnGuardedRhs () + +-- | case pattern match p -> e +match :: Pat () -> Exp () -> Alt () +match p e = Alt () p (urhs e) Nothing + +eWildCard :: Int -> EWildcard () +eWildCard = EWildcard () +-} diff --git a/fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs b/fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs index 23f9d5e2..60c547fb 100644 --- a/fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs +++ b/fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs @@ -1,4 +1,82 @@ -module FFICXX.Generate.Util.HaskellSrcExts where +module FFICXX.Generate.Util.HaskellSrcExts + ( app, + app', + unqual, + tycon, + tyapp, + tyfun, + tylist, + unit_tycon, + conDecl, + qualConDecl, + recDecl, + lit, + mkVar, + con, + doE, + listE, + strE, + qualStmt, + mkTVar, + mkPVar, + mkIVar, + mkPVarSig, + pbind, + pbind_, + mkTBind, + mkBind1, + mkFun, + mkFunSig, + mkClass, + dhead, + mkDeclHead, + mkInstance, + mkData, + mkNewtype, + mkForImpCcall, + mkModule, + mkModuleE, + mkImport, + mkImportExp, + mkImportSrc, + lang, + dot, + tyForall, + tyParen, + tyPtr, + tyForeignPtr, + classA, + cxEmpty, + cxTuple, + tySplice, + tyTupleBoxed, + parenSplice, + bracketExp, + typeBracket, + mkDeriving, + irule, + ihcon, + evar, + eabs, + ethingwith, + ethingall, + emodule, + nonamespace, + insType, + insDecl, + generator, + qualifier, + clsDecl, + unkindedVar, + op, + inapp, + if_, + urhs, + match, + eWildCard, + prettyPrint, + ) +where import Data.List (foldl') import Data.Maybe (maybeToList) @@ -99,13 +177,19 @@ import Language.Haskell.Exts TyList, TyParen, TySplice, + TyTuple, TyVar ), - app, - unit_tycon, ) +import qualified Language.Haskell.Exts as LHE import Language.Haskell.Exts.Syntax (CName) +app :: Exp () -> Exp () -> Exp () +app = LHE.app + +app' :: String -> String -> Exp () +app' x y = App () (mkVar x) (mkVar y) + unqual :: String -> QName () unqual = UnQual () . Ident () @@ -126,7 +210,7 @@ tylist :: Type () -> Type () tylist = TyList () unit_tycon :: Type () -unit_tycon = Language.Haskell.Exts.unit_tycon () +unit_tycon = LHE.unit_tycon () conDecl :: String -> [Type ()] -> ConDecl () conDecl n ys = ConDecl () (Ident () n) ys @@ -141,9 +225,6 @@ qualConDecl = QualConDecl () recDecl :: String -> [FieldDecl ()] -> ConDecl () recDecl n rs = RecDecl () (Ident () n) rs -app' :: String -> String -> Exp () -app' x y = App () (mkVar x) (mkVar y) - lit :: Literal () -> Exp () lit = Lit () @@ -153,6 +234,18 @@ mkVar = Var () . unqual con :: String -> Exp () con = Con () . unqual +doE :: [Stmt ()] -> Exp () +doE = LHE.doE + +listE :: [Exp ()] -> Exp () +listE = LHE.listE + +strE :: String -> Exp () +strE = LHE.strE + +qualStmt :: Exp () -> Stmt () +qualStmt = LHE.qualStmt + mkTVar :: String -> Type () mkTVar = TyVar () . Ident () @@ -271,6 +364,9 @@ cxTuple = CxTuple () tySplice :: Splice () -> Type () tySplice = TySplice () +tyTupleBoxed :: [Type ()] -> Type () +tyTupleBoxed = TyTuple () LHE.Boxed + parenSplice :: Exp () -> Splice () parenSplice = ParenSplice () @@ -348,3 +444,9 @@ urhs = UnGuardedRhs () -- | case pattern match p -> e match :: Pat () -> Exp () -> Alt () match p e = Alt () p (urhs e) Nothing + +eWildCard :: Int -> EWildcard () +eWildCard = EWildcard () + +prettyPrint :: (LHE.Pretty a) => a -> String +prettyPrint = LHE.prettyPrint From a2463e4217ce9b2b16c720d49a8ddfa0d48cb3e6 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Tue, 8 Aug 2023 19:01:06 -0700 Subject: [PATCH 03/19] FFI module generation via ghc-exactprint (#213) * simplify imports * start using ghc-exactprint for HsFFI * mkForImpCcall * hsFFIFunType almost implemented. FFI import formatting * unfortunately, i had to resort to a dirty solution for foreign imports. * c2HsType, postProcess * generated HsFFI code works. * format --- fficxx/fficxx.cabal | 2 +- fficxx/src/FFICXX/Generate/Builder.hs | 26 ++- fficxx/src/FFICXX/Generate/Code/HsFFI.hs | 53 ++++-- fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs | 13 +- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 160 +++++++++++++++++- fficxx/src/FFICXX/Generate/ContentMaker.hs | 34 ++-- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 157 ++++++++++++----- stdcxx-gen/Gen.hs | 2 +- 8 files changed, 369 insertions(+), 78 deletions(-) diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 0c155ef6..4aff3380 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -32,7 +32,7 @@ Library , filepath>1 , hashable , lens > 3 - , mtl>2 + , mtl > 2 , process , pureMD5 , split diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 3cc7876c..216a01d1 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -8,6 +8,7 @@ import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (toUpper) import Data.Digest.Pure.MD5 (md5) import Data.Foldable (for_) +import qualified Data.List as List import qualified Data.Text as T import FFICXX.Generate.Code.Cabal (buildCabalFile, buildJSONFile) import FFICXX.Generate.Config @@ -56,6 +57,20 @@ import System.Process (readProcess) macrofy :: String -> String macrofy = map ((\x -> if x == '-' then '_' else x) . toUpper) +postProcess :: String -> String +postProcess txt = unlines ls' + where + ls = lines txt + ls' = fmap process ls + -- + process line = + if "REPLACE_THIS_LINE" `List.isInfixOf` line + then + let (_, _ : xs) = List.break (== '|') line + (ys, _) = List.span (/= '|') xs + in ys + else line + simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO () simpleBuilder cfg sbc = do putStrLn "----------------------------------------------------" @@ -143,7 +158,7 @@ simpleBuilder cfg sbc = do for_ mods $ \m -> gen (cmModule m <.> "FFI" <.> "hsc") - (prettyPrint (C.buildFFIHsc m)) + (postProcess $ exactPrint (C.buildFFIHsc m)) -- putStrLn "Generating Interface.hs" for_ mods $ \m -> @@ -166,12 +181,9 @@ simpleBuilder cfg sbc = do putStrLn "Generating Proxy.hs" for_ mods $ \m -> when (hasProxy . cihClass . cmCIH $ m) $ do - let x = C.buildProxyHs m - putStrLn (Exact.showAst x) - putStrLn "-------" - putStrLn (exactPrint (C.buildProxyHs m)) - putStrLn "-------" - gen (cmModule m <.> "Proxy" <.> "hs") (exactPrint (C.buildProxyHs m)) + gen + (cmModule m <.> "Proxy" <.> "hs") + (exactPrint (C.buildProxyHs m)) -- putStrLn "Generating Template.hs" for_ tcms $ \m -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs index f6963651..f327590f 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs @@ -9,8 +9,10 @@ import FFICXX.Generate.Code.Primitive accessorCFunSig, genericFuncArgs, genericFuncRet, - hsFFIFuncTyp, + hsFFIFunType, ) +-- +import qualified FFICXX.Generate.Code.Primitive as O (hsFFIFuncTyp) import FFICXX.Generate.Dependency ( class_allparents, ) @@ -40,12 +42,23 @@ import FFICXX.Generate.Type.Module TopLevelImportHeader (..), ) import FFICXX.Generate.Util (toLowers) -import FFICXX.Generate.Util.HaskellSrcExts (mkForImpCcall, mkImport) +import FFICXX.Generate.Util.GHCExactPrint + ( mkForImpCcall, + mkImport, + ) +import qualified FFICXX.Generate.Util.HaskellSrcExts as O import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) -import Language.Haskell.Exts.Syntax (Decl, ImportDecl) +import GHC.Hs + ( GhcPs, + ) +import qualified Language.Haskell.Exts.Syntax as O +import Language.Haskell.Syntax + ( ForeignDecl, + ImportDecl, + ) import System.FilePath ((<.>)) -genHsFFI :: ClassImportHeader -> [Decl ()] +genHsFFI :: ClassImportHeader -> [ForeignDecl GhcPs] genHsFFI header = let c = cihClass header -- TODO: This C header information should not be necessary according to up-to-date @@ -65,7 +78,7 @@ genHsFFI header = (\v -> [hsFFIAccessor c v Getter, hsFFIAccessor c v Setter]) (class_vars c) -hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (Decl ()) +hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (ForeignDecl GhcPs) hsFFIClassFunc headerfilename c f = if isAbstractClass c then Nothing @@ -76,26 +89,29 @@ hsFFIClassFunc headerfilename c f = csig = CFunSig (genericFuncArgs f) (genericFuncRet f) typ = if (isNewFunc f || isStaticFunc f) - then hsFFIFuncTyp (Just (NoSelf, c)) csig - else hsFFIFuncTyp (Just (Self, c)) csig + then hsFFIFunType (Just (NoSelf, c)) csig + else hsFFIFunType (Just (Self, c)) csig in Just (mkForImpCcall (hfile <> " " <> cname) (hscFuncName c f) typ) -hsFFIAccessor :: Class -> Variable -> Accessor -> Decl () +hsFFIAccessor :: Class -> Variable -> Accessor -> ForeignDecl GhcPs hsFFIAccessor c v a = let -- TODO: make this a separate function cname = ffiClassName c <> "_" <> arg_name (unVariable v) <> "_" <> (case a of Getter -> "get"; Setter -> "set") - typ = hsFFIFuncTyp (Just (Self, c)) (accessorCFunSig (arg_type (unVariable v)) a) + typ = + hsFFIFunType + (Just (Self, c)) + (accessorCFunSig (arg_type (unVariable v)) a) in mkForImpCcall cname (hscAccessorName c v a) typ -- import for FFI -genImportInFFI :: ClassModule -> [ImportDecl ()] +genImportInFFI :: ClassModule -> [ImportDecl GhcPs] genImportInFFI = fmap (mkImport . subModuleName) . cmImportedSubmodulesForFFI ---------------------------- -- for top level function -- ---------------------------- -genTopLevelFFI :: TopLevelImportHeader -> TLOrdinary -> Decl () +genTopLevelFFI :: TopLevelImportHeader -> TLOrdinary -> ForeignDecl GhcPs genTopLevelFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ where (fname, args, ret) = @@ -105,4 +121,17 @@ genTopLevelFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) c hfilename = tihHeaderFileName header <.> "h" -- TODO: This must be exposed as a top-level function cfname = "c_" <> toLowers fname - typ = hsFFIFuncTyp Nothing (CFunSig args ret) + typ = hsFFIFunType Nothing (CFunSig args ret) + +-- TODO: Remove +genTopLevelFFI_ :: TopLevelImportHeader -> TLOrdinary -> O.Decl () +genTopLevelFFI_ header tfn = O.mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ + where + (fname, args, ret) = + case tfn of + TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret) + TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret) + hfilename = tihHeaderFileName header <.> "h" + -- TODO: This must be exposed as a top-level function + cfname = "c_" <> toLowers fname + typ = O.hsFFIFuncTyp Nothing (CFunSig args ret) diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs index 14630fd1..77deec0d 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -63,6 +63,8 @@ import FFICXX.Generate.Type.Module TemplateClassModule (..), ) import FFICXX.Generate.Util (toLowers) +-- +import qualified FFICXX.Generate.Util.GHCExactPrint as Ex import FFICXX.Generate.Util.HaskellSrcExts ( classA, clsDecl, @@ -103,12 +105,14 @@ import FFICXX.Generate.Util.HaskellSrcExts unkindedVar, unqual, ) +import qualified GHC.Hs as Ex import Language.Haskell.Exts.Build (app, letE, name, pApp) import Language.Haskell.Exts.Syntax ( Decl, ExportSpec, ImportDecl, ) +import qualified Language.Haskell.Syntax as Ex import System.FilePath ((<.>)) genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ()) @@ -329,8 +333,13 @@ genExportStatic c = map (evar . unqual) fns -- Import -- ------------ -genExtraImport :: ClassModule -> [ImportDecl ()] -genExtraImport cm = map mkImport (cmExtraImport cm) +-- TODO: Remvoe +genExtraImport_ :: ClassModule -> [ImportDecl ()] +genExtraImport_ cm = map mkImport (cmExtraImport cm) + +-- This is the new version. +genExtraImport :: ClassModule -> [Ex.ImportDecl Ex.GhcPs] +genExtraImport cm = fmap Ex.mkImport (cmExtraImport cm) genImportInModule :: Class -> [ImportDecl ()] genImportInModule x = map (\y -> mkImport (getClassModuleBase x <.> y)) ["RawType", "Interface", "Implementation"] diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index d7cfda1a..3df453d1 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -35,6 +35,7 @@ import FFICXX.Generate.Type.Class isNonVirtualFunc, isVirtualFunc, ) +import qualified FFICXX.Generate.Util.GHCExactPrint as Ex import FFICXX.Generate.Util.HaskellSrcExts ( classA, cxTuple, @@ -52,11 +53,15 @@ import FFICXX.Generate.Util.HaskellSrcExts ) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import GHC.Hs (GhcPs) import Language.Haskell.Exts.Syntax ( Asst, Context, Type, ) +import Language.Haskell.Syntax + ( HsType, + ) data CFunSig = CFunSig { cArgTypes :: [Arg], @@ -721,6 +726,51 @@ convertC2HS (CEnum t _) = convertC2HS t convertC2HS (CPointer t) = tyapp (tycon "Ptr") (convertC2HS t) convertC2HS (CRef t) = tyapp (tycon "Ptr") (convertC2HS t) +-- new +c2HsType :: CTypes -> HsType GhcPs +c2HsType CTBool = Ex.tycon "CBool" +c2HsType CTChar = Ex.tycon "CChar" +c2HsType CTClock = Ex.tycon "CClock" +c2HsType CTDouble = Ex.tycon "CDouble" +c2HsType CTFile = Ex.tycon "CFile" +c2HsType CTFloat = Ex.tycon "CFloat" +c2HsType CTFpos = Ex.tycon "CFpos" +c2HsType CTInt = Ex.tycon "CInt" +c2HsType CTIntMax = Ex.tycon "CIntMax" +c2HsType CTIntPtr = Ex.tycon "CIntPtr" +c2HsType CTJmpBuf = Ex.tycon "CJmpBuf" +c2HsType CTLLong = Ex.tycon "CLLong" +c2HsType CTLong = Ex.tycon "CLong" +c2HsType CTPtrdiff = Ex.tycon "CPtrdiff" +c2HsType CTSChar = Ex.tycon "CSChar" +c2HsType CTSUSeconds = Ex.tycon "CSUSeconds" +c2HsType CTShort = Ex.tycon "CShort" +c2HsType CTSigAtomic = Ex.tycon "CSigAtomic" +c2HsType CTSize = Ex.tycon "CSize" +c2HsType CTTime = Ex.tycon "CTime" +c2HsType CTUChar = Ex.tycon "CUChar" +c2HsType CTUInt = Ex.tycon "CUInt" +c2HsType CTUIntMax = Ex.tycon "CUIntMax" +c2HsType CTUIntPtr = Ex.tycon "CUIntPtr" +c2HsType CTULLong = Ex.tycon "CULLong" +c2HsType CTULong = Ex.tycon "CULong" +c2HsType CTUSeconds = Ex.tycon "CUSeconds" +c2HsType CTUShort = Ex.tycon "CUShort" +c2HsType CTWchar = Ex.tycon "CWchar" +c2HsType CTInt8 = Ex.tycon "Int8" +c2HsType CTInt16 = Ex.tycon "Int16" +c2HsType CTInt32 = Ex.tycon "Int32" +c2HsType CTInt64 = Ex.tycon "Int64" +c2HsType CTUInt8 = Ex.tycon "Word8" +c2HsType CTUInt16 = Ex.tycon "Word16" +c2HsType CTUInt32 = Ex.tycon "Word32" +c2HsType CTUInt64 = Ex.tycon "Word64" +c2HsType CTString = Ex.tycon "CString" +c2HsType CTVoidStar = Ex.tyapp (Ex.tycon "Ptr") Ex.unit_tycon +c2HsType (CEnum t _) = c2HsType t +c2HsType (CPointer t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) +c2HsType (CRef t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) + convertCpp2HS :: Maybe Class -> Types -> Type () convertCpp2HS _c Void = unit_tycon convertCpp2HS (Just c) SelfType = tycon ((fst . hsClassName) c) @@ -955,7 +1005,7 @@ accessorSignature c v accessor = arg0 = (mkTVar (fst (hsClassName c)) :) in tyForall Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) --- | this is for FFI type. +-- | old function. this is for FFI type. hsFFIFuncTyp :: Maybe (Selfness, Class) -> CFunSig -> Type () hsFFIFuncTyp msc (CFunSig args ret) = foldr1 tyfun $ case msc of @@ -1056,6 +1106,114 @@ hsFFIFuncTyp msc (CFunSig args ret) = hsrettype (TemplateParam p) = mkTVar p hsrettype (TemplateParamPointer p) = mkTVar p +-- | new function +hsFFIFunType :: Maybe (Selfness, Class) -> CFunSig -> HsType GhcPs +hsFFIFunType msc (CFunSig args ret) = + foldr1 Ex.tyfun allTypes + where + allTypes = + case msc of + Nothing -> argtyps <> [Ex.tyapp (Ex.tycon "IO") rettyp] + Just (Self, _) -> selftyp : argtyps <> [Ex.tyapp (Ex.tycon "IO") rettyp] + Just (NoSelf, _) -> argtyps <> [Ex.tyapp (Ex.tycon "IO") rettyp] + argtyps :: [HsType GhcPs] + argtyps = map (hsargtype . arg_type) args + -- + rettyp :: HsType GhcPs + rettyp = Ex.tyParen (hsrettype ret) + -- + selftyp = case msc of + Just (_, c) -> Ex.tyapp Ex.tyPtr (Ex.tycon (snd (hsClassName c))) + Nothing -> error "hsFFIFuncTyp: no self for top level function" + -- + hsargtype :: Types -> HsType GhcPs + hsargtype (CT ctype _) = c2HsType ctype + hsargtype (CPT (CPTClass d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsargtype (CPT (CPTClassRef d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsargtype (CPT (CPTClassMove d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsargtype (CPT (CPTClassCopy d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsargtype (TemplateApp x) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where + rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsargtype (TemplateAppRef x) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where + rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsargtype (TemplateAppMove x) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where + rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsargtype (TemplateType t) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp (Ex.tycon rawname : map Ex.mkTVar (tclass_params t)) + where + rawname = snd (hsTemplateClassName t) + hsargtype (TemplateParam p) = Ex.mkTVar p + hsargtype SelfType = selftyp + hsargtype _ = error "hsFuncTyp: undefined hsargtype" + --------------------------------------------------------- + hsrettype Void = Ex.unit_tycon + hsrettype SelfType = selftyp + hsrettype (CT ctype _) = c2HsType ctype + hsrettype (CPT (CPTClass d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsrettype (CPT (CPTClassRef d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsrettype (CPT (CPTClassCopy d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsrettype (CPT (CPTClassMove d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) + where + rawname = snd (hsClassName d) + hsrettype (TemplateApp x) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where + rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsrettype (TemplateAppRef x) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where + rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsrettype (TemplateAppMove x) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where + rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsrettype (TemplateType t) = + Ex.tyapp Ex.tyPtr $ + foldl1 Ex.tyapp (Ex.tycon rawname : map Ex.mkTVar (tclass_params t)) + where + rawname = snd (hsTemplateClassName t) + hsrettype (TemplateParam p) = Ex.mkTVar p + hsrettype (TemplateParamPointer p) = Ex.mkTVar p + genericFuncRet :: Function -> Types genericFuncRet f = case f of diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 4a0d9a04..2013e88a 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -37,10 +37,12 @@ import FFICXX.Generate.Code.HsFFI ( genHsFFI, genImportInFFI, genTopLevelFFI, + genTopLevelFFI_, ) import FFICXX.Generate.Code.HsFrontEnd ( genExport, genExtraImport, + genExtraImport_, genHsFrontDecl, genHsFrontDowncastClass, genHsFrontInst, @@ -125,7 +127,11 @@ import Language.Haskell.Exts.Syntax ( Decl, Module, ) -import Language.Haskell.Syntax (HsModule) +import Language.Haskell.Syntax + ( HsDecl (ForD), + HsModule, + noExtField, + ) import System.FilePath ((<.>), ()) srcDir :: FilePath -> FilePath @@ -329,25 +335,25 @@ buildTopLevelCppDef tih = ] ) -buildFFIHsc :: ClassModule -> Module () +buildFFIHsc :: ClassModule -> HsModule GhcPs buildFFIHsc m = - mkModule + Ex.mkModule (mname <.> "FFI") - [lang ["ForeignFunctionInterface", "InterruptibleFFI"]] + ["ForeignFunctionInterface", "InterruptibleFFI"] ffiImports hscBody where mname = cmModule m ffiImports = - [ mkImport "Data.Word", - mkImport "Data.Int", - mkImport "Foreign.C", - mkImport "Foreign.Ptr", - mkImport (mname <.> "RawType") + [ Ex.mkImport "Data.Word", + Ex.mkImport "Data.Int", + Ex.mkImport "Foreign.C", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport (mname <.> "RawType") ] <> genImportInFFI m <> genExtraImport m - hscBody = genHsFFI (cmCIH m) + hscBody = fmap (ForD noExtField) (genHsFFI (cmCIH m)) buildRawTypeHs :: ClassModule -> Module () buildRawTypeHs m = @@ -407,7 +413,7 @@ buildInterfaceHs amap depCycles m = mkImport "FFICXX.Runtime.Cast" ] <> genImportInInterface False depCycles m - <> genExtraImport m + <> genExtraImport_ m ifaceBody = runReader (mapM (genHsFrontDecl False) classes) amap <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes @@ -441,7 +447,7 @@ buildInterfaceHsBoot depCycles m = mkImport "FFICXX.Runtime.Cast" ] <> genImportInInterface True depCycles m - <> genExtraImport m + <> genExtraImport_ m hsbootBody = runReader (mapM (genHsFrontDecl True) [c]) M.empty @@ -507,7 +513,7 @@ buildImplementationHs amap m = mkImport "FFICXX.Runtime.TH" -- for template member ] <> genImportInImplementation m - <> genExtraImport m + <> genExtraImport_ m f :: Class -> [Decl ()] f y = concatMap (flip genHsFrontInst y) (y : class_allparents y) implBody = @@ -636,7 +642,7 @@ buildTopLevelOrdinaryHs modname (_mods, tmods) tih = ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods ++ concatMap genImportForTLOrdinary (filterTLOrdinary tfns) pkgBody = - map (genTopLevelFFI tih) (filterTLOrdinary tfns) + map (genTopLevelFFI_ tih) (filterTLOrdinary tfns) ++ concatMap genTopLevelDef (filterTLOrdinary tfns) buildTopLevelTemplateHs :: diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index 258dccf5..7ee1bfcf 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -5,17 +5,22 @@ module FFICXX.Generate.Util.GHCExactPrint ( -- * module mkModule, - -- * import + -- * import and FFI mkImport, + mkForImpCcall, -- * names unqual, -- * types mkTVar, - tycon, tyapp, + tycon, + tyfun, tylist, + tyParen, + tyPtr, + unit_tycon, -- * function mkFun, @@ -36,8 +41,6 @@ module FFICXX.Generate.Util.GHCExactPrint -- * stmt mkBodyStmt, {- app', - tyfun, - unit_tycon, conDecl, qualConDecl, recDecl, @@ -55,7 +58,6 @@ module FFICXX.Generate.Util.GHCExactPrint mkInstance, mkData, mkNewtype, - mkForImpCcall, mkModuleE, mkImportExp, mkImportSrc, @@ -63,7 +65,6 @@ module FFICXX.Generate.Util.GHCExactPrint dot, tyForall, tyParen, - tyPtr, tyForeignPtr, classA, cxEmpty, @@ -102,19 +103,13 @@ import Data.List (foldl') import Data.Maybe (maybeToList) import Data.String (IsString (fromString)) import GHC.Hs - ( AnnsModule (..), + ( AnnSig (..), + AnnsModule (..), + GhcPs, GrhsAnn (..), + XImportDeclPass (..), XModulePs (..), ) -import GHC.Hs.Binds - ( AnnSig (..), - ) -import GHC.Hs.Extension - ( GhcPs, - ) -import GHC.Hs.ImpExp - ( XImportDeclPass (..), - ) import GHC.Parser.Annotation ( AddEpAnn (..), Anchor (..), @@ -126,11 +121,11 @@ import GHC.Parser.Annotation DeltaPos (..), EpAnn (..), EpaComment (..), - EpaCommentTok (EpaLineComment), + EpaCommentTok (..), EpaLocation (..), NameAnn (..), NoEpAnns (..), - ParenType (AnnParensSquare), + ParenType (AnnParens, AnnParensSquare), SrcAnn, SrcSpanAnn' (SrcSpanAnn), SrcSpanAnnA, @@ -146,6 +141,11 @@ import GHC.Types.Basic import GHC.Types.Fixity ( LexicalFixity (Prefix), ) +import GHC.Types.ForeignCall + ( CCallConv (..), + CCallTarget (StaticTarget), + Safety (..), + ) import GHC.Types.Name.Occurrence ( OccName, mkOccName, @@ -172,9 +172,13 @@ import GHC.Types.SrcLoc import qualified Language.Haskell.GHC.ExactPrint as Exact import Language.Haskell.Syntax ( Anno, + CImportSpec (CFunction), ExprLStmt, + ForeignDecl (..), + ForeignImport (CImport), GRHS (..), GRHSs (..), + HsArrow (..), HsBind (..), HsBindLR (..), HsDecl (..), @@ -188,7 +192,9 @@ import Language.Haskell.Syntax HsOuterTyVarBndrs (HsOuterImplicit), HsSigType (HsSig), HsToken (..), + HsTupleSort (..), HsType (..), + HsUniToken (..), HsWildCardBndrs (HsWC), ImportDecl (..), ImportDeclQualifiedStyle (..), @@ -215,7 +221,7 @@ mkRelAnchor nLines = | nLines < -1 -> error "mkRelAnchor: cannot go backward further" | nLines == -1 -> a' {anchor_op = MovedAnchor (SameLine 0)} | nLines == 0 -> a' {anchor_op = MovedAnchor (SameLine 1)} - | nLines > 0 -> a' {anchor_op = MovedAnchor (DifferentLine nLines 0)} + | otherwise -> a' {anchor_op = MovedAnchor (DifferentLine nLines 0)} mkRelEpAnn :: Int -> ann -> EpAnn ann mkRelEpAnn nLines ann = EpAnn (mkRelAnchor nLines) ann emptyComments @@ -266,6 +272,13 @@ noAnnListItem = AnnListItem [] mkL :: Int -> a -> GenLocated SrcSpanAnnA a mkL nLines = L (mkRelSrcSpanAnn nLines noAnnListItem) +tokLoc :: Int -> TokenLocation +tokLoc nLines + | nLines < -1 = error "tokLoc: cannot go below -1" + | nLines == -1 = TokenLoc (EpaDelta (SameLine 0) []) + | nLines == 0 = TokenLoc (EpaDelta (SameLine 1) []) + | otherwise = TokenLoc (EpaDelta (DifferentLine nLines 0) []) + -- -- Modules -- @@ -334,6 +347,53 @@ mkImport name = where modName = ModuleName (fromString name) +-- NOTE: Unfortunately, the location annotation of GHC API for foreign import is not fully relative, +-- i.e. we cannot place correct spaces between "import", "ccall" and "safe", and the generated result +-- is not a valid Haskell code. So as a workaround we need to put a place holder in comment. +mkForImpCcall :: String -> String -> HsType GhcPs -> ForeignDecl GhcPs +mkForImpCcall quote fname typ = + ForeignImport (mkRelEpAnn (-1) anns) lid lsigty forImp + where + quote' = show quote + anns = + [ AddEpAnn + AnnForeign + ( EpaDelta + (SameLine 0) + [ L + (mkRelAnchor 0) + ( EpaComment + ( EpaBlockComment + ( "{- REPLACE_THIS_LINE |foreign import ccall interruptible \"" + <> quote + <> "\"| -}" + ) + ) + defRealSrcSpan + ) + ] + ), + AddEpAnn AnnImport (EpaDelta (SameLine 1) []), + AddEpAnn AnnDcolon (EpaDelta (SameLine 1) []) + ] + id' = unqual (mkVarOcc fname) + lid = + let a = spanAsAnchor defSrcSpan + a' = a {anchor_op = MovedAnchor (DifferentLine 1 2)} + in L (SrcSpanAnn (EpAnn a' (NameAnnTrailing []) emptyComments) defSrcSpan) id' + outer = HsOuterImplicit noExtField + sigty = HsSig noExtField outer (mkL (-1) typ) + lsigty = mkL 0 sigty + forImp = + CImport + (L defSrcSpan {- anchor_op = MovedAnchor (SameLine 1) -} (SourceText quote')) + (L defSrcSpan {- anchor_op = MovedAnchor (SameLine 1) -} StdCallConv) + (L defSrcSpan {- anchor_op = MovedAnchor (SameLine 1) -} PlayInterruptible) + Nothing + ( CFunction + (StaticTarget (SourceText quote) (fromString quote) Nothing True) + ) + -- -- names -- @@ -363,6 +423,19 @@ tyapp x y = lx = mkL (-1) x ly = mkL 0 y +infixl 2 `tyapp` + +tyfun :: HsType GhcPs -> HsType GhcPs -> HsType GhcPs +tyfun x y = + HsFunTy ann arrow lx ly + where + ann = mkRelEpAnn (-1) NoEpAnns + arrow = HsUnrestrictedArrow (L (tokLoc (-1)) HsNormalTok) + lx = mkL (-1) x + ly = mkL 0 y + +infixr 2 `tyfun` + tylist :: HsType GhcPs -> HsType GhcPs tylist x = HsListTy (mkRelEpAnn (-1) ann) lx @@ -375,6 +448,29 @@ tylist x = } lx = mkL (-1) x +tyParen :: HsType GhcPs -> HsType GhcPs +tyParen typ = + HsParTy (mkRelEpAnn (-1) ann) (mkL (-1) typ) + where + ann = + AnnParen + AnnParens + (EpaDelta (SameLine 0) []) + (EpaDelta (SameLine 0) []) + +tyPtr :: HsType GhcPs +tyPtr = tycon "Ptr" + +unit_tycon :: HsType GhcPs +unit_tycon = + HsTupleTy (mkRelEpAnn (-1) ann) HsBoxedOrConstraintTuple [] + where + ann = + AnnParen + AnnParens + (EpaDelta (SameLine 0) []) + (EpaDelta (SameLine 0) []) + -- -- Function -- @@ -538,8 +634,8 @@ par expr = HsPar ann tokOpen (mkL (-1) expr) tokClose where ann = mkRelEpAnn (-1) NoEpAnns - tokOpen = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok - tokClose = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok + tokOpen = L (tokLoc (-1)) HsTok + tokClose = L (tokLoc (-1)) HsTok strE :: String -> HsExpr GhcPs strE str = HsLit ann1 (HsString ann2 (fromString str)) @@ -681,16 +777,6 @@ app' x y = App () (mkVar x) (mkVar y) unqual :: String -> QName () unqual = UnQual () . Ident () -infixl 2 `tyapp` - -tyfun :: Type () -> Type () -> Type () -tyfun = TyFun () - -infixr 2 `tyfun` - -unit_tycon :: Type () -unit_tycon = LHE.unit_tycon () - conDecl :: String -> [Type ()] -> ConDecl () conDecl n ys = ConDecl () (Ident () n) ys @@ -752,9 +838,6 @@ mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qde where declhead = mkDeclHead n tbinds -mkForImpCcall :: String -> String -> Type () -> Decl () -mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlayInterruptible ())) (Just quote) (Ident () n) typ - mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module () mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls where @@ -783,12 +866,6 @@ tyForall :: Type () tyForall = TyForall () -tyParen :: Type () -> Type () -tyParen = TyParen () - -tyPtr :: Type () -tyPtr = tycon "Ptr" - tyForeignPtr :: Type () tyForeignPtr = tycon "ForeignPtr" diff --git a/stdcxx-gen/Gen.hs b/stdcxx-gen/Gen.hs index 3e512c01..49aa078d 100644 --- a/stdcxx-gen/Gen.hs +++ b/stdcxx-gen/Gen.hs @@ -57,7 +57,7 @@ cabal :: Cabal cabal = Cabal { cabal_pkgname = CabalName "stdcxx", - cabal_version = "0.7.0.1", + cabal_version = "0.8.0.0", cabal_cheaderprefix = "STD", cabal_moduleprefix = "STD", cabal_additional_c_incs = [], From 83f70dc6dc8798208b62a1fe3a57de067a478890 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Wed, 9 Aug 2023 12:55:05 -0700 Subject: [PATCH 04/19] HsCast module migrated to ghc-exactprint (#214) Handling typeclass instance declaration with ghc-exactprint. * refactor out mkDeltaPos and mkEpaDelta * mkInstance implementation * migrate HsCast to ghc-exactprint * correct handling trailing commas. * generated code is compilable! * fix parentheses * ormolu format --- experiments/sample.hs | 3 + fficxx/src/FFICXX/Generate/Builder.hs | 10 +- fficxx/src/FFICXX/Generate/Code/HsCast.hs | 84 ++++++- fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs | 11 +- fficxx/src/FFICXX/Generate/Code/HsTemplate.hs | 4 +- fficxx/src/FFICXX/Generate/ContentMaker.hs | 24 +- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 208 ++++++++++++------ workspace/build_short2.sh | 5 +- 8 files changed, 250 insertions(+), 99 deletions(-) diff --git a/experiments/sample.hs b/experiments/sample.hs index 858fee00..12e55669 100644 --- a/experiments/sample.hs +++ b/experiments/sample.hs @@ -8,3 +8,6 @@ data K = K Int test :: IO () test = do addModFinalizer (addForeignSource LangCxx "\n#include \"test\"") + +instance (C a) => D (P a) (Q a) where + dinst x = x * x diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 216a01d1..1b5a21c4 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -6,6 +6,7 @@ module FFICXX.Generate.Builder where import Control.Monad (void, when) import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (toUpper) +import Data.Data (Data) import Data.Digest.Pure.MD5 (md5) import Data.Foldable (for_) import qualified Data.List as List @@ -71,6 +72,13 @@ postProcess txt = unlines ls' in ys else line +debugExactPrint :: (Exact.ExactPrint a, Data a) => a -> IO () +debugExactPrint x = do + putStrLn (Exact.showAst x) + putStrLn "-------" + putStrLn (exactPrint x) + putStrLn "-------" + simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO () simpleBuilder cfg sbc = do putStrLn "----------------------------------------------------" @@ -170,7 +178,7 @@ simpleBuilder cfg sbc = do for_ mods $ \m -> gen (cmModule m <.> "Cast" <.> "hs") - (prettyPrint (C.buildCastHs m)) + (exactPrint (C.buildCastHs m)) -- putStrLn "Generating Implementation.hs" for_ mods $ \m -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs index c0ce209c..9d1f277e 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCast.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCast.hs @@ -1,9 +1,26 @@ module FFICXX.Generate.Code.HsCast where --- import FFICXX.Generate.Name (hsClassName, typeclassName) import FFICXX.Generate.Type.Class (Class (..), isAbstractClass) -import FFICXX.Generate.Util.HaskellSrcExts +import FFICXX.Generate.Util.GHCExactPrint + ( app, + classA, + cxEmpty, + cxTuple, + instD, + mkBind1, + mkInstance, + mkPVar, + mkTVar, + mkVar, + par, + tyPtr, + tyapp, + tycon, + ) +-- + +import qualified FFICXX.Generate.Util.HaskellSrcExts as O ( app, classA, cxEmpty, @@ -19,29 +36,72 @@ import FFICXX.Generate.Util.HaskellSrcExts tycon, unqual, ) -import Language.Haskell.Exts.Syntax (Decl, InstDecl) +import GHC.Hs (GhcPs) +import qualified Language.Haskell.Exts.Syntax as O (Decl, InstDecl) +import Language.Haskell.Syntax + ( HsBind, + HsDecl, + ) ------ +castBody_ :: [O.InstDecl ()] +castBody_ = + [ O.insDecl (O.mkBind1 "cast" [O.mkPVar "x", O.mkPVar "f"] (O.app (O.mkVar "f") (O.app (O.mkVar "castPtr") (O.app (O.mkVar "get_fptr") (O.mkVar "x")))) Nothing), + O.insDecl (O.mkBind1 "uncast" [O.mkPVar "x", O.mkPVar "f"] (O.app (O.mkVar "f") (O.app (O.mkVar "cast_fptr_to_obj") (O.app (O.mkVar "castPtr") (O.mkVar "x")))) Nothing) + ] -castBody :: [InstDecl ()] +castBody :: [HsBind GhcPs] 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) + [ mkBind1 + "cast" + [mkPVar "x", mkPVar "f"] + ( app + (mkVar "f") + ( par + ( app + (mkVar "castPtr") + ( par + ( app + (mkVar "get_fptr") + (mkVar "x") + ) + ) + ) + ) + ) + Nothing, + mkBind1 + "uncast" + [mkPVar "x", mkPVar "f"] + ( app + (mkVar "f") + ( par + ( app + (mkVar "cast_fptr_to_obj") + ( par + ( app + (mkVar "castPtr") + (mkVar "x") + ) + ) + ) + ) + ) + Nothing ] -genHsFrontInstCastable :: Class -> Maybe (Decl ()) +genHsFrontInstCastable :: Class -> Maybe (HsDecl GhcPs) 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) + ctxt = cxTuple [classA iname [a], classA "FPtr" [a]] + in Just (instD (mkInstance ctxt "Castable" [a, tyapp tyPtr (tycon rname)] castBody)) | otherwise = Nothing -genHsFrontInstCastableSelf :: Class -> Maybe (Decl ()) +genHsFrontInstCastableSelf :: Class -> Maybe (HsDecl GhcPs) genHsFrontInstCastableSelf c | (not . isAbstractClass) c = let (cname, rname) = hsClassName c - in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody) + in Just (instD (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody)) | otherwise = Nothing diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs index 77deec0d..f746da5a 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -367,10 +367,17 @@ genImportInInterface isHsBoot depCycles m = in fmap mkImport imported' else fmap (mkImportWithDepCycles depCycles modSelf . subModuleName) imported -genImportInCast :: ClassModule -> [ImportDecl ()] -genImportInCast m = +-- OLD +-- TODO: Remove +genImportInCast_ :: ClassModule -> [ImportDecl ()] +genImportInCast_ m = fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m +-- NEW +genImportInCast :: ClassModule -> [Ex.ImportDecl Ex.GhcPs] +genImportInCast m = + fmap (Ex.mkImport . subModuleName) $ cmImportedSubmodulesForCast m + genImportInImplementation :: ClassModule -> [ImportDecl ()] genImportInImplementation m = fmap (mkImport . subModuleName) $ cmImportedSubmodulesForImplementation m diff --git a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs index 4eecdc4b..386ac508 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs @@ -10,7 +10,7 @@ import FFICXX.Generate.Code.Cpp genTmplFunCpp, genTmplVarCpp, ) -import FFICXX.Generate.Code.HsCast (castBody) +import FFICXX.Generate.Code.HsCast (castBody_) import FFICXX.Generate.Code.Primitive ( convertCpp2HS, convertCpp2HS4Tmpl, @@ -248,7 +248,7 @@ genTmplInterface t = Nothing, mkClass cxEmpty (typeclassNameT t) (map mkTBind tps) methods, mkInstance cxEmpty "FPtr" [hightype] fptrbody, - mkInstance cxEmpty "Castable" [hightype, tyapp tyPtr rawtype] castBody + mkInstance cxEmpty "Castable" [hightype, tyapp tyPtr rawtype] castBody_ ] where (hname, rname) = hsTemplateClassName t diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 2013e88a..880cadd9 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -451,27 +451,25 @@ buildInterfaceHsBoot depCycles m = hsbootBody = runReader (mapM (genHsFrontDecl True) [c]) M.empty -buildCastHs :: ClassModule -> Module () +buildCastHs :: ClassModule -> HsModule GhcPs buildCastHs m = - mkModule + Ex.mkModule (cmModule m <.> "Cast") - [ lang - [ "FlexibleInstances", - "FlexibleContexts", - "TypeFamilies", - "MultiParamTypeClasses", - "OverlappingInstances", - "IncoherentInstances" - ] + [ "FlexibleInstances", + "FlexibleContexts", + "TypeFamilies", + "MultiParamTypeClasses", + "OverlappingInstances", + "IncoherentInstances" ] castImports body where classes = [cihClass (cmCIH m)] castImports = - [ mkImport "Foreign.Ptr", - mkImport "FFICXX.Runtime.Cast", - mkImport "System.IO.Unsafe" + [ Ex.mkImport "Foreign.Ptr", + Ex.mkImport "FFICXX.Runtime.Cast", + Ex.mkImport "System.IO.Unsafe" ] <> genImportInCast m body = diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index 7ee1bfcf..000bb616 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -27,6 +27,16 @@ module FFICXX.Generate.Util.GHCExactPrint mkFunSig, mkBind1, + -- * Typeclass + cxEmpty, + cxTuple, + classA, + mkInstance, + instD, + + -- * pattern + mkPVar, + -- * expr app, con, @@ -67,8 +77,6 @@ module FFICXX.Generate.Util.GHCExactPrint tyParen, tyForeignPtr, classA, - cxEmpty, - cxTuple, tySplice, tyTupleBoxed, parenSplice, @@ -102,6 +110,7 @@ where import Data.List (foldl') import Data.Maybe (maybeToList) import Data.String (IsString (fromString)) +import GHC.Data.Bag (listToBag) import GHC.Hs ( AnnSig (..), AnnsModule (..), @@ -114,15 +123,18 @@ import GHC.Parser.Annotation ( AddEpAnn (..), Anchor (..), AnchorOperation (..), + AnnContext (..), AnnKeywordId (..), AnnList (..), AnnListItem (..), AnnParen (..), + AnnSortKey (..), DeltaPos (..), EpAnn (..), EpaComment (..), EpaCommentTok (..), EpaLocation (..), + IsUnicodeSyntax (NormalSyntax), NameAnn (..), NoEpAnns (..), ParenType (AnnParens, AnnParensSquare), @@ -130,6 +142,7 @@ import GHC.Parser.Annotation SrcSpanAnn' (SrcSpanAnn), SrcSpanAnnA, TokenLocation (..), + TrailingAnn (..), emptyComments, noAnn, noSrcSpanA, @@ -173,6 +186,7 @@ import qualified Language.Haskell.GHC.ExactPrint as Exact import Language.Haskell.Syntax ( Anno, CImportSpec (CFunction), + ClsInstDecl (..), ExprLStmt, ForeignDecl (..), ForeignImport (CImport), @@ -181,6 +195,7 @@ import Language.Haskell.Syntax HsArrow (..), HsBind (..), HsBindLR (..), + HsContext (..), HsDecl (..), HsDoFlavour (..), HsExpr (..), @@ -198,8 +213,10 @@ import Language.Haskell.Syntax HsWildCardBndrs (HsWC), ImportDecl (..), ImportDeclQualifiedStyle (..), + InstDecl (..), IsBootInterface (..), LHsExpr, + LIdP, LayoutInfo (..), Match (..), MatchGroup (..), @@ -214,14 +231,23 @@ import Language.Haskell.Syntax.Basic ( SrcStrictness (NoSrcStrict), ) +mkDeltaPos :: Int -> DeltaPos +mkDeltaPos nLines + | nLines < -1 = error "mkDeltaPos: cannot go backward further" + | nLines == -1 = SameLine 0 + | nLines == 0 = SameLine 1 + | otherwise = DifferentLine nLines 0 + +mkEpaDelta :: Int -> EpaLocation +mkEpaDelta nLines = EpaDelta (mkDeltaPos nLines) [] + +tokLoc :: Int -> TokenLocation +tokLoc nLines = TokenLoc (mkEpaDelta nLines) + mkRelAnchor :: Int -> Anchor mkRelAnchor nLines = let a' = spanAsAnchor defSrcSpan - in if - | nLines < -1 -> error "mkRelAnchor: cannot go backward further" - | nLines == -1 -> a' {anchor_op = MovedAnchor (SameLine 0)} - | nLines == 0 -> a' {anchor_op = MovedAnchor (SameLine 1)} - | otherwise -> a' {anchor_op = MovedAnchor (DifferentLine nLines 0)} + in a' {anchor_op = MovedAnchor (mkDeltaPos nLines)} mkRelEpAnn :: Int -> ann -> EpAnn ann mkRelEpAnn nLines ann = EpAnn (mkRelAnchor nLines) ann emptyComments @@ -272,13 +298,6 @@ noAnnListItem = AnnListItem [] mkL :: Int -> a -> GenLocated SrcSpanAnnA a mkL nLines = L (mkRelSrcSpanAnn nLines noAnnListItem) -tokLoc :: Int -> TokenLocation -tokLoc nLines - | nLines < -1 = error "tokLoc: cannot go below -1" - | nLines == -1 = TokenLoc (EpaDelta (SameLine 0) []) - | nLines == 0 = TokenLoc (EpaDelta (SameLine 1) []) - | otherwise = TokenLoc (EpaDelta (DifferentLine nLines 0) []) - -- -- Modules -- @@ -320,8 +339,8 @@ mkModule name pragmas idecls decls = in ls a1 = AnnsModule - [ AddEpAnn AnnModule (EpaDelta (DifferentLine 2 0) pragmaComments), - AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) + [ AddEpAnn AnnModule (EpaDelta (mkDeltaPos 2) pragmaComments), + AddEpAnn AnnWhere (mkEpaDelta 0) ] (AnnList Nothing Nothing Nothing [] []) @@ -359,7 +378,7 @@ mkForImpCcall quote fname typ = [ AddEpAnn AnnForeign ( EpaDelta - (SameLine 0) + (mkDeltaPos (-1)) [ L (mkRelAnchor 0) ( EpaComment @@ -373,8 +392,8 @@ mkForImpCcall quote fname typ = ) ] ), - AddEpAnn AnnImport (EpaDelta (SameLine 1) []), - AddEpAnn AnnDcolon (EpaDelta (SameLine 1) []) + AddEpAnn AnnImport (mkEpaDelta 0), + AddEpAnn AnnDcolon (mkEpaDelta 0) ] id' = unqual (mkVarOcc fname) lid = @@ -401,6 +420,11 @@ mkForImpCcall quote fname typ = unqual :: OccName -> RdrName unqual = Unqual +mkLIdP :: String -> LIdP GhcPs +mkLIdP name = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' + where + id' = unqual (mkVarOcc name) + -- -- types -- @@ -443,8 +467,8 @@ tylist x = ann = AnnParen { ap_adornment = AnnParensSquare, - ap_open = EpaDelta (SameLine 0) [], - ap_close = EpaDelta (SameLine 0) [] + ap_open = mkEpaDelta (-1), + ap_close = mkEpaDelta (-1) } lx = mkL (-1) x @@ -452,11 +476,7 @@ tyParen :: HsType GhcPs -> HsType GhcPs tyParen typ = HsParTy (mkRelEpAnn (-1) ann) (mkL (-1) typ) where - ann = - AnnParen - AnnParens - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) []) + ann = AnnParen AnnParens (mkEpaDelta (-1)) (mkEpaDelta (-1)) tyPtr :: HsType GhcPs tyPtr = tycon "Ptr" @@ -465,11 +485,7 @@ unit_tycon :: HsType GhcPs unit_tycon = HsTupleTy (mkRelEpAnn (-1) ann) HsBoxedOrConstraintTuple [] where - ann = - AnnParen - AnnParens - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) []) + ann = AnnParen AnnParens (mkEpaDelta (-1)) (mkEpaDelta (-1)) -- -- Function @@ -490,7 +506,7 @@ mkFun :: [HsDecl GhcPs] mkFun fname typ pats rhs mbinds = [ mkFunSig fname typ, - mkBind1 fname pats rhs mbinds + ValD noExtField (mkBind1 fname pats rhs mbinds) ] mkFunSig :: @@ -502,7 +518,7 @@ mkFunSig fname typ = SigD noExtField (TypeSig ann [lid] bndr) where ann = - mkRelEpAnn (-1) (AnnSig (AddEpAnn AnnDcolon (EpaDelta (SameLine 1) [])) []) + mkRelEpAnn (-1) (AnnSig (AddEpAnn AnnDcolon (mkEpaDelta 0)) []) id' = unqual (mkVarOcc fname) lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' @@ -518,20 +534,20 @@ mkBind1 :: [Pat GhcPs] -> HsExpr GhcPs -> Maybe (HsLocalBinds GhcPs) -> - HsDecl GhcPs + HsBind GhcPs mkBind1 fname pats rhs mbinds = - ValD noExtField (FunBind noExtField lid payload) + FunBind noExtField lid payload where id' = unqual (mkVarOcc fname) lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' - lpats = [] -- fmap (L ) pats - lrhs = mkL (-1) rhs + lpats = fmap (mkL 0) pats + lrhs = mkL 0 rhs glrhs = let ann = mkRelEpAnn (-1) - (GrhsAnn Nothing (AddEpAnn AnnEqual (EpaDelta (SameLine 1) []))) + (GrhsAnn Nothing (AddEpAnn AnnEqual (mkEpaDelta 0))) in GRHS ann [] (lrhs) lglrhs = L (mkRelSrcSpanAnn (-1) NoEpAnns) glrhs match = @@ -549,6 +565,94 @@ mkBind1 fname pats rhs mbinds = lmatch = mkL (-1) match payload = MG FromSource (L (mkRelSrcSpanAnn (-1) noAnnList) [lmatch]) +-- +-- Typeclass +-- + +cxEmpty :: HsContext GhcPs +cxEmpty = [] + +cxTuple :: [HsType GhcPs] -> HsContext GhcPs +cxTuple typs = + case typs of + [] -> [] + (x : []) -> [mkL (-1) x] + _ -> + let typs' = init typs + lastTyp = last typs + typs'' = + fmap + (L (mkRelSrcSpanAnn (-1) (AnnListItem [AddCommaAnn (mkEpaDelta (-1))]))) + typs' + in (typs'' ++ [mkL (-1) lastTyp]) + +classA :: String -> [HsType GhcPs] -> HsType GhcPs +classA name typs = foldl' tyapp (tycon name) typs' + where + typs' = fmap tyParen typs + +mkInstance :: + -- | Context + HsContext GhcPs -> + -- | Typeclass name + String -> + -- | instance types + [HsType GhcPs] -> + -- | instance definitions + [HsBind GhcPs] -> + -- | resultant declaration + ClsInstDecl GhcPs +mkInstance ctxt name typs bnds = + ClsInstDecl + { cid_ext = ann, + cid_poly_ty = + mkL (-1) (HsSig noExtField (HsOuterImplicit noExtField) (mkL (-1) typcls)), + cid_binds = bnds', + cid_sigs = [], + cid_tyfam_insts = [], + cid_datafam_insts = [], + cid_overlap_mode = Nothing + } + where + bnds' = listToBag $ fmap (L ann') bnds + where + a = spanAsAnchor defSrcSpan + a' = a {anchor_op = MovedAnchor (DifferentLine 1 2)} + ann' = SrcSpanAnn (EpAnn a' noAnnListItem emptyComments) defSrcSpan + ann = + ( mkRelEpAnn + 1 + [ AddEpAnn AnnInstance (mkEpaDelta (-1)), + AddEpAnn AnnWhere (mkEpaDelta 0) + ], + NoAnnSortKey + ) + typcls = + HsQualTy + { hst_xqual = noExtField, + hst_ctxt = L (mkRelSrcSpanAnn 0 annCtxt) ctxt, + hst_body = mkL 0 insttyp + } + annCtxt = + AnnContext + { ac_darrow = Just (NormalSyntax, mkEpaDelta 0), + ac_open = [mkEpaDelta (-1)], + ac_close = [mkEpaDelta (-1)] + } + insttyp = foldl' f (tycon name) typs + where + f acc x = tyapp acc (tyParen x) + +instD :: ClsInstDecl GhcPs -> HsDecl GhcPs +instD = InstD noExtField . ClsInstD noExtField + +-- +-- Pattern +-- + +mkPVar :: String -> Pat GhcPs +mkPVar name = VarPat noExtField (mkLIdP name) + -- -- Expr -- @@ -621,10 +725,7 @@ listE itms = mkVar :: String -> HsExpr GhcPs mkVar name = - HsVar noExtField lid - where - id' = unqual (mkVarOcc name) - lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' + HsVar noExtField (mkLIdP name) op :: String -> HsExpr GhcPs op = mkVar @@ -793,9 +894,6 @@ recDecl n rs = RecDecl () (Ident () n) rs lit :: Literal () -> Exp () lit = Lit () -mkPVar :: String -> Pat () -mkPVar = PVar () . Ident () - mkIVar :: String -> ImportSpec () mkIVar = IVar () . Ident () @@ -820,14 +918,6 @@ dhead n = DHead () (Ident () n) mkDeclHead :: String -> [TyVarBind ()] -> DeclHead () mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds -mkInstance :: Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl () -mkInstance ctxt n typs idecls = InstDecl () Nothing instrule (Just idecls) - where - instrule = IRule () Nothing (Just ctxt) insthead - insthead = foldl' f (IHCon () (unqual n)) typs - where - f acc x = IHApp () acc (tyParen x) - mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv) where @@ -869,15 +959,6 @@ tyForall = TyForall () tyForeignPtr :: Type () tyForeignPtr = tycon "ForeignPtr" -classA :: QName () -> [Type ()] -> Asst () -classA n = TypeA () . foldl' tyapp (TyCon () n) - -cxEmpty :: Context () -cxEmpty = CxEmpty () - -cxTuple :: [Asst ()] -> Context () -cxTuple = CxTuple () - tySplice :: Splice () -> Type () tySplice = TySplice () @@ -931,9 +1012,6 @@ nonamespace = NoNamespace () insType :: Type () -> Type () -> InstDecl () insType = InsType () -insDecl :: Decl () -> InstDecl () -insDecl = InsDecl () - generator :: Pat () -> Exp () -> Stmt () generator = Generator () diff --git a/workspace/build_short2.sh b/workspace/build_short2.sh index 10066145..ad21d732 100755 --- a/workspace/build_short2.sh +++ b/workspace/build_short2.sh @@ -3,10 +3,7 @@ rm -rf stdcxx rm -rf tmf-test rm -rf proxy-test rm -rf working -cabal new-build fficxx -sleep 1s -cabal new-exec runhaskell ../stdcxx-gen/Gen.hs -cabal new-build stdcxx +cabal new-build fficxx && cabal new-exec runhaskell ../stdcxx-gen/Gen.hs && cabal new-build stdcxx # map rm map/test.o map/test From 086e022d5f5b44302e38784b40b6ff989d8649ae Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Wed, 9 Aug 2023 18:55:56 -0700 Subject: [PATCH 05/19] RawType code generation via ghc-exactprint (#215) Separated out HsRawType out of HsFrontend. implemented mkData, mkNewtype, mkDeriving etc. so that RawType can be generated and tested. * separate out HsRawType * mkData, mkNewtype. HsRawType is almost converted. * now no missing part in HsRawType * mkDeriving * mkTypeFamInst * generated code formatting correctly. now it works! * ormolu --- experiments/sample.hs | 3 + fficxx/fficxx.cabal | 1 + fficxx/src/FFICXX/Generate/Builder.hs | 5 +- fficxx/src/FFICXX/Generate/Code/HsCast.hs | 14 +- fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs | 23 -- fficxx/src/FFICXX/Generate/Code/HsRawType.hs | 62 +++++ fficxx/src/FFICXX/Generate/ContentMaker.hs | 29 +- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 253 ++++++++++++++---- 8 files changed, 288 insertions(+), 102 deletions(-) create mode 100644 fficxx/src/FFICXX/Generate/Code/HsRawType.hs diff --git a/experiments/sample.hs b/experiments/sample.hs index 12e55669..ab1b28b5 100644 --- a/experiments/sample.hs +++ b/experiments/sample.hs @@ -10,4 +10,7 @@ test = do addModFinalizer (addForeignSource LangCxx "\n#include \"test\"") instance (C a) => D (P a) (Q a) where + type F (P a) = Double dinst x = x * x + +newtype Loader = Loader (Ptr RawLoader) deriving (Eq, Ord, Show) diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 4aff3380..20d0c6f4 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -59,6 +59,7 @@ Library FFICXX.Generate.Code.HsFFI FFICXX.Generate.Code.HsFrontEnd FFICXX.Generate.Code.HsProxy + FFICXX.Generate.Code.HsRawType FFICXX.Generate.Code.HsTemplate FFICXX.Generate.Code.Cabal FFICXX.Generate.Code.Primitive diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 1b5a21c4..d6f7ee16 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -157,10 +157,11 @@ simpleBuilder cfg sbc = do for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt) -- putStrLn "Generating RawType.hs" - for_ mods $ \m -> + for_ mods $ \m -> do + debugExactPrint (C.buildRawTypeHs m) gen (cmModule m <.> "RawType" <.> "hs") - (prettyPrint (C.buildRawTypeHs m)) + (exactPrint (C.buildRawTypeHs m)) -- putStrLn "Generating FFI.hsc" for_ mods $ \m -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs index 9d1f277e..04941a74 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCast.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCast.hs @@ -18,8 +18,6 @@ import FFICXX.Generate.Util.GHCExactPrint tyapp, tycon, ) --- - import qualified FFICXX.Generate.Util.HaskellSrcExts as O ( app, classA, @@ -96,12 +94,20 @@ genHsFrontInstCastable c (_, rname) = hsClassName c a = mkTVar "a" ctxt = cxTuple [classA iname [a], classA "FPtr" [a]] - in Just (instD (mkInstance ctxt "Castable" [a, tyapp tyPtr (tycon rname)] castBody)) + in Just (instD (mkInstance ctxt "Castable" [a, tyapp tyPtr (tycon rname)] [] castBody)) | otherwise = Nothing genHsFrontInstCastableSelf :: Class -> Maybe (HsDecl GhcPs) genHsFrontInstCastableSelf c | (not . isAbstractClass) c = let (cname, rname) = hsClassName c - in Just (instD (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody)) + in Just $ + instD + ( mkInstance + cxEmpty + "Castable" + [tycon cname, tyapp tyPtr (tycon rname)] + [] + castBody + ) | otherwise = Nothing diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs index f746da5a..d6e89d53 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -189,29 +189,6 @@ genHsFrontInstVariables c = -------------------------- -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")) - ------------ -- upcast -- ------------ diff --git a/fficxx/src/FFICXX/Generate/Code/HsRawType.hs b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs new file mode 100644 index 00000000..25dcd34d --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs @@ -0,0 +1,62 @@ +module FFICXX.Generate.Code.HsRawType + ( hsClassRawType, + ) +where + +import FFICXX.Generate.Name (hsClassName) +import FFICXX.Generate.Type.Class (Class (..)) +import FFICXX.Generate.Util.GHCExactPrint + ( con, + conDecl, + cxEmpty, + instD, + mkBind1, + mkData, + mkDeriving, + mkInstance, + mkNewtype, + mkPVar, + mkTypeFamInst, + mkVar, + pApp, + parP, + tyPtr, + tyapp, + tycon, + ) +import GHC.Hs (GhcPs) +import Language.Haskell.Syntax + ( HsDecl (TyClD), + noExtField, + ) + +hsClassRawType :: Class -> [HsDecl GhcPs] +hsClassRawType c = + [ TyClD noExtField (mkData rawname [] []), + TyClD + noExtField + ( mkNewtype + highname + (conDecl highname [tyapp tyPtr rawtype]) + deriv + ), + instD $ + mkInstance + cxEmpty + "FPtr" + [hightype] + [ mkTypeFamInst "Raw" [hightype] rawtype + ] + [ mkBind1 + "get_fptr" + [parP (pApp highname [mkPVar "ptr"])] + (mkVar "ptr") + Nothing, + mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing + ] + ] + where + (highname, rawname) = hsClassName c + hightype = tycon highname + rawtype = tycon rawname + deriv = mkDeriving [tycon "Eq", tycon "Ord", tycon "Show"] diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 880cadd9..df244fb1 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -36,7 +36,6 @@ import FFICXX.Generate.Code.HsCast import FFICXX.Generate.Code.HsFFI ( genHsFFI, genImportInFFI, - genTopLevelFFI, genTopLevelFFI_, ) import FFICXX.Generate.Code.HsFrontEnd @@ -59,9 +58,9 @@ import FFICXX.Generate.Code.HsFrontEnd genImportInModule, genImportInTopLevel, genTopLevelDef, - hsClassRawType, ) import FFICXX.Generate.Code.HsProxy (genProxyInstance) +import FFICXX.Generate.Code.HsRawType (hsClassRawType) import FFICXX.Generate.Code.HsTemplate ( genImportInTH, genImportInTemplate, @@ -355,27 +354,25 @@ buildFFIHsc m = <> genExtraImport m hscBody = fmap (ForD noExtField) (genHsFFI (cmCIH m)) -buildRawTypeHs :: ClassModule -> Module () +buildRawTypeHs :: ClassModule -> HsModule GhcPs buildRawTypeHs m = - mkModule + Ex.mkModule (cmModule m <.> "RawType") - [ lang - [ "ForeignFunctionInterface", - "TypeFamilies", - "MultiParamTypeClasses", - "FlexibleInstances", - "TypeSynonymInstances", - "EmptyDataDecls", - "ExistentialQuantification", - "ScopedTypeVariables" - ] + [ "ForeignFunctionInterface", + "TypeFamilies", + "MultiParamTypeClasses", + "FlexibleInstances", + "TypeSynonymInstances", + "EmptyDataDecls", + "ExistentialQuantification", + "ScopedTypeVariables" ] rawtypeImports rawtypeBody where rawtypeImports = - [ mkImport "Foreign.Ptr", - mkImport "FFICXX.Runtime.Cast" + [ Ex.mkImport "Foreign.Ptr", + Ex.mkImport "FFICXX.Runtime.Cast" ] rawtypeBody = let c = cihClass (cmCIH m) diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index 000bb616..9fa1ecd4 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -22,6 +22,12 @@ module FFICXX.Generate.Util.GHCExactPrint tyPtr, unit_tycon, + -- * data/newtype declaration + mkData, + mkNewtype, + conDecl, + mkDeriving, + -- * function mkFun, mkFunSig, @@ -32,10 +38,13 @@ module FFICXX.Generate.Util.GHCExactPrint cxTuple, classA, mkInstance, + mkTypeFamInst, instD, -- * pattern mkPVar, + pApp, + parP, -- * expr app, @@ -66,8 +75,6 @@ module FFICXX.Generate.Util.GHCExactPrint dhead, mkDeclHead, mkInstance, - mkData, - mkNewtype, mkModuleE, mkImportExp, mkImportSrc, @@ -82,7 +89,6 @@ module FFICXX.Generate.Util.GHCExactPrint parenSplice, bracketExp, typeBracket, - mkDeriving, irule, ihcon, evar, @@ -187,16 +193,25 @@ import Language.Haskell.Syntax ( Anno, CImportSpec (CFunction), ClsInstDecl (..), + ConDecl (..), + DataDefnCons (..), + DerivClauseTys (..), ExprLStmt, + FamEqn (..), ForeignDecl (..), ForeignImport (CImport), GRHS (..), GRHSs (..), + HsArg (..), HsArrow (..), HsBind (..), HsBindLR (..), + HsConDetails (PrefixCon), HsContext (..), + HsDataDefn (..), HsDecl (..), + HsDeriving (..), + HsDerivingClause (..), HsDoFlavour (..), HsExpr (..), HsLit (..), @@ -205,7 +220,8 @@ import Language.Haskell.Syntax HsMatchContext (FunRhs), HsModule (..), HsOuterTyVarBndrs (HsOuterImplicit), - HsSigType (HsSig), + HsScaled (..), + HsSigType (..), HsToken (..), HsTupleSort (..), HsType (..), @@ -216,6 +232,7 @@ import Language.Haskell.Syntax InstDecl (..), IsBootInterface (..), LHsExpr, + LHsQTyVars (..), LIdP, LayoutInfo (..), Match (..), @@ -225,7 +242,10 @@ import Language.Haskell.Syntax PromotionFlag (..), Sig (TypeSig), StmtLR (..), + TyClDecl (..), + TyFamInstDecl (..), noExtField, + noTypeArgs, ) import Language.Haskell.Syntax.Basic ( SrcStrictness (NoSrcStrict), @@ -298,6 +318,13 @@ noAnnListItem = AnnListItem [] mkL :: Int -> a -> GenLocated SrcSpanAnnA a mkL nLines = L (mkRelSrcSpanAnn nLines noAnnListItem) +mkL' :: DeltaPos -> a -> GenLocated SrcSpanAnnA a +mkL' delta = L anno' + where + a = spanAsAnchor defSrcSpan + a' = a {anchor_op = MovedAnchor delta} + anno' = SrcSpanAnn (EpAnn a' (AnnListItem []) emptyComments) defSrcSpan + -- -- Modules -- @@ -371,10 +398,10 @@ mkImport name = -- is not a valid Haskell code. So as a workaround we need to put a place holder in comment. mkForImpCcall :: String -> String -> HsType GhcPs -> ForeignDecl GhcPs mkForImpCcall quote fname typ = - ForeignImport (mkRelEpAnn (-1) anns) lid lsigty forImp + ForeignImport (mkRelEpAnn (-1) annos) lid lsigty forImp where quote' = show quote - anns = + annos = [ AddEpAnn AnnForeign ( EpaDelta @@ -420,8 +447,8 @@ mkForImpCcall quote fname typ = unqual :: OccName -> RdrName unqual = Unqual -mkLIdP :: String -> LIdP GhcPs -mkLIdP name = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' +mkLIdP :: Int -> String -> LIdP GhcPs +mkLIdP nLines name = L (mkRelSrcSpanAnn nLines (NameAnnTrailing [])) id' where id' = unqual (mkVarOcc name) @@ -487,6 +514,108 @@ unit_tycon = where ann = AnnParen AnnParens (mkEpaDelta (-1)) (mkEpaDelta (-1)) +-- +-- data/newtype declaration +-- + +mkData :: + -- | data type name + String -> + -- [TyVarBind ()] -> + [ConDecl GhcPs] -> + HsDeriving GhcPs -> + TyClDecl GhcPs +mkData name {- tbinds -} cdecls deriv = + DataDecl (mkRelEpAnn (-1) annos) (mkLIdP 0 name) qty Prefix dfn + where + annos = + [ AddEpAnn AnnData (mkEpaDelta (-1)) + ] + qty = HsQTvs noExtField [] + dfn = + HsDataDefn + { dd_ext = noExtField, + dd_ctxt = Nothing, + dd_cType = Nothing, + dd_kindSig = Nothing, + dd_cons = DataTypeCons False (fmap (mkL (-1)) cdecls), + dd_derivs = deriv + } + +mkNewtype :: + -- | newtype name + String -> + -- [TyVarBind ()] -> + ConDecl GhcPs -> + HsDeriving GhcPs -> + TyClDecl GhcPs +mkNewtype name {- tbinds -} cdecl deriv = + DataDecl (mkRelEpAnn (-1) annos) (mkLIdP 0 name) qty Prefix dfn + where + annos = + [ AddEpAnn AnnNewtype (mkEpaDelta (-1)), + AddEpAnn AnnEqual (mkEpaDelta 0) + ] + qty = HsQTvs noExtField [] + dfn = + HsDataDefn + { dd_ext = noExtField, + dd_ctxt = Nothing, + dd_cType = Nothing, + dd_kindSig = Nothing, + dd_cons = NewTypeCon (mkL 0 cdecl), + dd_derivs = deriv + } + +conDecl :: String -> [HsType GhcPs] -> ConDecl GhcPs +conDecl name typs = + ConDeclH98 + { con_ext = mkRelEpAnn (-1) [], + con_name = mkLIdP (-1) name, + con_forall = False, + con_ex_tvs = [], + con_mb_cxt = Nothing, + con_args = details, + con_doc = Nothing + } + where + details = PrefixCon noTypeArgs args + args = + fmap (HsScaled (HsUnrestrictedArrow (L NoTokenLoc HsNormalTok))) ltyps + ltyps = fmap (mkL 0 . tyParen) typs + +mkDeriving :: [HsType GhcPs] -> HsDeriving GhcPs +mkDeriving typs = [L (mkRelSrcSpanAnn 0 NoEpAnns) clause] + where + clause = + HsDerivingClause + { deriv_clause_ext = + mkRelEpAnn + (-1) + [ AddEpAnn AnnDeriving (mkEpaDelta (-1)) + ], + deriv_clause_strategy = Nothing, + deriv_clause_tys = + L + ( mkRelSrcSpanAnn + (-1) + ( AnnContext + { ac_darrow = Nothing, + ac_open = [mkEpaDelta 0], + ac_close = [mkEpaDelta (-1)] + } + ) + ) + typs' + } + typs' = DctMulti noExtField (tupleAnn $ fmap mkSigTy typs) + mkSigTy t = + HsSig + { sig_ext = noExtField, + sig_bndrs = HsOuterImplicit noExtField, + sig_body = mkL (-1) t + } + -- -- Function -- @@ -565,6 +694,18 @@ mkBind1 fname pats rhs mbinds = lmatch = mkL (-1) match payload = MG FromSource (L (mkRelSrcSpanAnn (-1) noAnnList) [lmatch]) +tupleAnn :: [a] -> [GenLocated SrcSpanAnnA a] +tupleAnn [] = [] +tupleAnn (x : []) = [mkL (-1) x] +tupleAnn xs = + let xs' = init xs + lastX = last xs + xs'' = + fmap + (L (mkRelSrcSpanAnn (-1) (AnnListItem [AddCommaAnn (mkEpaDelta (-1))]))) + xs' + in (xs'' ++ [mkL (-1) lastX]) + -- -- Typeclass -- @@ -573,18 +714,7 @@ cxEmpty :: HsContext GhcPs cxEmpty = [] cxTuple :: [HsType GhcPs] -> HsContext GhcPs -cxTuple typs = - case typs of - [] -> [] - (x : []) -> [mkL (-1) x] - _ -> - let typs' = init typs - lastTyp = last typs - typs'' = - fmap - (L (mkRelSrcSpanAnn (-1) (AnnListItem [AddCommaAnn (mkEpaDelta (-1))]))) - typs' - in (typs'' ++ [mkL (-1) lastTyp]) +cxTuple = tupleAnn classA :: String -> [HsType GhcPs] -> HsType GhcPs classA name typs = foldl' tyapp (tycon name) typs' @@ -598,18 +728,20 @@ mkInstance :: String -> -- | instance types [HsType GhcPs] -> - -- | instance definitions + -- | instance type family declarations + [TyFamInstDecl GhcPs] -> + -- | instance function definitions [HsBind GhcPs] -> -- | resultant declaration ClsInstDecl GhcPs -mkInstance ctxt name typs bnds = +mkInstance ctxt name typs tyfams bnds = ClsInstDecl { cid_ext = ann, cid_poly_ty = mkL (-1) (HsSig noExtField (HsOuterImplicit noExtField) (mkL (-1) typcls)), cid_binds = bnds', cid_sigs = [], - cid_tyfam_insts = [], + cid_tyfam_insts = fmap (mkL' (DifferentLine 1 2)) tyfams, cid_datafam_insts = [], cid_overlap_mode = Nothing } @@ -643,6 +775,27 @@ mkInstance ctxt name typs bnds = where f acc x = tyapp acc (tyParen x) +mkTypeFamInst :: String -> [HsType GhcPs] -> HsType GhcPs -> TyFamInstDecl GhcPs +mkTypeFamInst name args typ = + TyFamInstDecl (mkRelEpAnn (-1) annos) eqn + where + annos = + [ AddEpAnn AnnType (mkEpaDelta (-1)) + ] + eqn = + FamEqn + { feqn_ext = + mkRelEpAnn + 0 + [ AddEpAnn AnnEqual (mkEpaDelta 0) + ], + feqn_tycon = mkLIdP (-1) name, + feqn_bndrs = HsOuterImplicit noExtField, + feqn_pats = fmap (\t -> HsValArg (mkL 0 t)) args, + feqn_fixity = Prefix, + feqn_rhs = mkL 0 typ + } + instD :: ClsInstDecl GhcPs -> HsDecl GhcPs instD = InstD noExtField . ClsInstD noExtField @@ -651,7 +804,25 @@ instD = InstD noExtField . ClsInstD noExtField -- mkPVar :: String -> Pat GhcPs -mkPVar name = VarPat noExtField (mkLIdP name) +mkPVar name = VarPat noExtField (mkLIdP (-1) name) + +pApp :: String -> [Pat GhcPs] -> Pat GhcPs +pApp name pats = + ConPat + { pat_con_ext = mkRelEpAnn (-1) [], + pat_con = mkLIdP (-1) name, + pat_args = PrefixCon [] lpats + } + where + lpats = fmap (mkL 0) pats + +parP :: Pat GhcPs -> Pat GhcPs +parP p = + ParPat + (mkRelEpAnn (-1) NoEpAnns) + (L (tokLoc (-1)) HsTok) + (mkL (-1) p) + (L (tokLoc (-1)) HsTok) -- -- Expr @@ -725,7 +896,7 @@ listE itms = mkVar :: String -> HsExpr GhcPs mkVar name = - HsVar noExtField (mkLIdP name) + HsVar noExtField (mkLIdP (-1) name) op :: String -> HsExpr GhcPs op = mkVar @@ -878,9 +1049,6 @@ app' x y = App () (mkVar x) (mkVar y) unqual :: String -> QName () unqual = UnQual () . Ident () -conDecl :: String -> [Type ()] -> ConDecl () -conDecl n ys = ConDecl () (Ident () n) ys - qualConDecl :: Maybe [TyVarBind ()] -> Maybe (Context ()) -> @@ -918,16 +1086,6 @@ dhead n = DHead () (Ident () n) mkDeclHead :: String -> [TyVarBind ()] -> DeclHead () mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds -mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () -mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv) - where - declhead = mkDeclHead n tbinds - -mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () -mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv) - where - declhead = mkDeclHead n tbinds - mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module () mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls where @@ -943,9 +1101,6 @@ mkImportExp m lst = mkImportSrc :: String -> ImportDecl () mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing -lang :: [String] -> ModulePragma () -lang ns = LanguagePragma () (map (Ident ()) ns) - dot :: Exp () -> Exp () -> Exp () x `dot` y = x `app` mkVar "." `app` y @@ -974,19 +1129,6 @@ bracketExp = BracketExp () typeBracket :: Type () -> Bracket () typeBracket = TypeBracket () -mkDeriving :: [InstRule ()] -> Deriving () -mkDeriving = Deriving () Nothing - -irule :: - Maybe [TyVarBind ()] -> - Maybe (Context ()) -> - InstHead () -> - InstRule () -irule = IRule () - -ihcon :: QName () -> InstHead () -ihcon = IHCon () - evar :: QName () -> ExportSpec () evar = EVar () @@ -1009,9 +1151,6 @@ emodule nm = EModuleContents () (ModuleName () nm) nonamespace :: Namespace () nonamespace = NoNamespace () -insType :: Type () -> Type () -> InstDecl () -insType = InsType () - generator :: Pat () -> Exp () -> Stmt () generator = Generator () From cf55d30521ad2ee989d22b099587f8863db79635 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Thu, 10 Aug 2023 09:10:22 -0700 Subject: [PATCH 06/19] Explode HsFrontEnd module (#216) to HsCommon, HsInterface, HsImplementation, HsTopLevel * separate out HsInterface * separate out HsImplementation * remove warnings in separated modules * remove warnings in HsCast * rename remaining HsFrontEnd to HsTopLevel * HsCommon module separation * remove warnings --- fficxx/fficxx.cabal | 5 +- fficxx/src/FFICXX/Generate/Builder.hs | 3 +- fficxx/src/FFICXX/Generate/Code/HsCast.hs | 43 +- fficxx/src/FFICXX/Generate/Code/HsCommon.hs | 32 ++ fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs | 395 ------------------ .../FFICXX/Generate/Code/HsImplementation.hs | 124 ++++++ .../src/FFICXX/Generate/Code/HsInterface.hs | 166 ++++++++ fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs | 193 +++++++++ fficxx/src/FFICXX/Generate/ContentMaker.hs | 34 +- 9 files changed, 571 insertions(+), 424 deletions(-) create mode 100644 fficxx/src/FFICXX/Generate/Code/HsCommon.hs delete mode 100644 fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs create mode 100644 fficxx/src/FFICXX/Generate/Code/HsImplementation.hs create mode 100644 fficxx/src/FFICXX/Generate/Code/HsInterface.hs create mode 100644 fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 20d0c6f4..958b2132 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -56,11 +56,14 @@ Library FFICXX.Generate.Config FFICXX.Generate.Code.Cpp FFICXX.Generate.Code.HsCast + FFICXX.Generate.Code.HsCommon FFICXX.Generate.Code.HsFFI - FFICXX.Generate.Code.HsFrontEnd + FFICXX.Generate.Code.HsImplementation + FFICXX.Generate.Code.HsInterface FFICXX.Generate.Code.HsProxy FFICXX.Generate.Code.HsRawType FFICXX.Generate.Code.HsTemplate + FFICXX.Generate.Code.HsTopLevel FFICXX.Generate.Code.Cabal FFICXX.Generate.Code.Primitive FFICXX.Generate.ContentMaker diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index d6f7ee16..b0e9b983 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -157,8 +157,7 @@ simpleBuilder cfg sbc = do for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt) -- putStrLn "Generating RawType.hs" - for_ mods $ \m -> do - debugExactPrint (C.buildRawTypeHs m) + for_ mods $ \m -> gen (cmModule m <.> "RawType" <.> "hs") (exactPrint (C.buildRawTypeHs m)) diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs index 04941a74..29ec13f3 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCast.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCast.hs @@ -1,7 +1,22 @@ -module FFICXX.Generate.Code.HsCast where +module FFICXX.Generate.Code.HsCast + ( -- * imports + genImportInCast, -import FFICXX.Generate.Name (hsClassName, typeclassName) + -- * code + castBody, + castBody_, + genHsFrontInstCastable, + genHsFrontInstCastableSelf, + ) +where + +import FFICXX.Generate.Name + ( hsClassName, + subModuleName, + typeclassName, + ) import FFICXX.Generate.Type.Class (Class (..), isAbstractClass) +import FFICXX.Generate.Type.Module (ClassModule (..)) import FFICXX.Generate.Util.GHCExactPrint ( app, classA, @@ -9,6 +24,7 @@ import FFICXX.Generate.Util.GHCExactPrint cxTuple, instD, mkBind1, + mkImport, mkInstance, mkPVar, mkTVar, @@ -20,27 +36,30 @@ import FFICXX.Generate.Util.GHCExactPrint ) import qualified FFICXX.Generate.Util.HaskellSrcExts as O ( app, - classA, - cxEmpty, - cxTuple, insDecl, mkBind1, - mkInstance, mkPVar, - mkTVar, mkVar, - tyPtr, - tyapp, - tycon, - unqual, ) import GHC.Hs (GhcPs) -import qualified Language.Haskell.Exts.Syntax as O (Decl, InstDecl) +import qualified Language.Haskell.Exts.Syntax as O (InstDecl) import Language.Haskell.Syntax ( HsBind, HsDecl, + ImportDecl, ) +-- +-- imports +-- + +genImportInCast :: ClassModule -> [ImportDecl GhcPs] +genImportInCast m = + fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m + +-- +-- code +-- castBody_ :: [O.InstDecl ()] castBody_ = [ O.insDecl (O.mkBind1 "cast" [O.mkPVar "x", O.mkPVar "f"] (O.app (O.mkVar "f") (O.app (O.mkVar "castPtr") (O.app (O.mkVar "get_fptr") (O.mkVar "x")))) Nothing), diff --git a/fficxx/src/FFICXX/Generate/Code/HsCommon.hs b/fficxx/src/FFICXX/Generate/Code/HsCommon.hs new file mode 100644 index 00000000..9476eaba --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Code/HsCommon.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsCommon + ( genExtraImport_, + genExtraImport, + genImportInCast_, + ) +where + +import FFICXX.Generate.Name (subModuleName) +import FFICXX.Generate.Type.Module (ClassModule (..)) +import qualified FFICXX.Generate.Util.GHCExactPrint as Ex +import FFICXX.Generate.Util.HaskellSrcExts (mkImport) +import qualified GHC.Hs as Ex +import Language.Haskell.Exts.Syntax (ImportDecl) + +-- TODO: Remove +genExtraImport_ :: ClassModule -> [ImportDecl ()] +genExtraImport_ cm = map mkImport (cmExtraImport cm) + +-- This is the new version. +genExtraImport :: ClassModule -> [Ex.ImportDecl Ex.GhcPs] +genExtraImport cm = fmap Ex.mkImport (cmExtraImport cm) + +-- OLD +-- TODO: Remove +genImportInCast_ :: ClassModule -> [ImportDecl ()] +genImportInCast_ m = + fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs deleted file mode 100644 index d6e89d53..00000000 --- a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module FFICXX.Generate.Code.HsFrontEnd where - -import Control.Monad.Reader (Reader) -import Data.Either (lefts, rights) -import qualified Data.List as L -import FFICXX.Generate.Code.Primitive - ( CFunSig (..), - HsFunSig (..), - accessorSignature, - classConstraints, - convertCpp2HS, - extractArgRetTypes, - functionSignature, - hsFuncXformer, - ) -import FFICXX.Generate.Dependency - ( argumentDependency, - extractClassDepForTLOrdinary, - extractClassDepForTLTemplate, - returnDependency, - ) -import FFICXX.Generate.Dependency.Graph - ( getCyclicDepSubmodules, - locateInDepCycles, - ) -import FFICXX.Generate.Name - ( accessorName, - aliasedFuncName, - getClassModuleBase, - getTClassModuleBase, - hsClassName, - hsFrontNameForTopLevel, - hsFuncName, - hscAccessorName, - hscFuncName, - subModuleName, - typeclassName, - ) -import FFICXX.Generate.Type.Annotate (AnnotateMap) -import FFICXX.Generate.Type.Class - ( Accessor (..), - Class (..), - TLOrdinary (..), - TLTemplate, - TopLevel (TLOrdinary), - Types (..), - constructorFuncs, - isAbstractClass, - isNewFunc, - isVirtualFunc, - nonVirtualNotNewFuncs, - staticFuncs, - virtualFuncs, - ) -import FFICXX.Generate.Type.Module - ( ClassModule (..), - DepCycles, - TemplateClassModule (..), - ) -import FFICXX.Generate.Util (toLowers) --- -import qualified FFICXX.Generate.Util.GHCExactPrint as Ex -import FFICXX.Generate.Util.HaskellSrcExts - ( classA, - clsDecl, - con, - conDecl, - cxEmpty, - cxTuple, - eabs, - ethingall, - evar, - ihcon, - insDecl, - insType, - irule, - mkBind1, - mkClass, - mkData, - mkDeriving, - mkFun, - mkFunSig, - mkImport, - mkImportSrc, - mkInstance, - mkNewtype, - mkPVar, - mkPVarSig, - mkTBind, - mkTVar, - mkVar, - nonamespace, - pbind, - qualConDecl, - tyForall, - tyPtr, - tyapp, - tycon, - tyfun, - unkindedVar, - unqual, - ) -import qualified GHC.Hs as Ex -import Language.Haskell.Exts.Build (app, letE, name, pApp) -import Language.Haskell.Exts.Syntax - ( Decl, - ExportSpec, - ImportDecl, - ) -import qualified Language.Haskell.Syntax as Ex -import System.FilePath ((<.>)) - -genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ()) -genHsFrontDecl isHsBoot c = do - -- TODO: revive annotation - -- for the time being, let's ignore annotation. - -- amap <- ask - -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap - let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body - -- for hs-boot, we only have instance head. - cdecl' = mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] [] - sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) - body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c - if isHsBoot - then return cdecl' - else 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 :: - -- | only concrete class - Class -> - Reader AnnotateMap [Decl ()] -genHsFrontInstNew c = do - -- amap <- ask - let fs = filter isNewFunc (class_funcs c) - return . flip concatMap fs $ \f -> - let -- for the time being, let's ignore annotation. - -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap - -- newfuncann = mkComment 0 cann - rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) - in mkFun (aliasedFuncName c f) (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 - ------ - -genHsFrontInstVariables :: Class -> [Decl ()] -genHsFrontInstVariables c = - flip concatMap (class_vars c) $ \v -> - let rhs accessor = - app - (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1")) - (mkVar (hscAccessorName c v accessor)) - in mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing - <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing - --------------------------- - ------------- --- upcast -- ------------- - -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") - --------------- --- downcast -- --------------- - -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") - ------------------------- --- Top Level Function -- ------------------------- - -genTopLevelDef :: TLOrdinary -> [Decl ()] -genTopLevelDef f@TopLevelFunction {..} = - let fname = hsFrontNameForTopLevel (TLOrdinary f) - HsFunSig typs assts = - extractArgRetTypes - Nothing - False - (CFunSig 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 -genTopLevelDef v@TopLevelVariable {..} = - let fname = hsFrontNameForTopLevel (TLOrdinary v) - cfname = "c_" <> toLowers fname - rtyp = convertCpp2HS Nothing toplevelvar_ret - sig = tyapp (tycon "IO") rtyp - rhs = app (mkVar "xformnull") (mkVar cfname) - in mkFun fname sig [] rhs Nothing - ------------- --- Export -- ------------- - -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 - --- | constructor and non-virtual function -genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()] -genExportConstructorAndNonvirtual c = map (evar . unqual) fns - where - fs = class_funcs c - fns = - map - (aliasedFuncName c) - ( constructorFuncs fs - <> nonVirtualNotNewFuncs fs - ) - --- | staic function export list -genExportStatic :: Class -> [ExportSpec ()] -genExportStatic c = map (evar . unqual) fns - where - fs = class_funcs c - fns = map (aliasedFuncName c) (staticFuncs fs) - ------------- --- Import -- ------------- - --- TODO: Remvoe -genExtraImport_ :: ClassModule -> [ImportDecl ()] -genExtraImport_ cm = map mkImport (cmExtraImport cm) - --- This is the new version. -genExtraImport :: ClassModule -> [Ex.ImportDecl Ex.GhcPs] -genExtraImport cm = fmap Ex.mkImport (cmExtraImport cm) - -genImportInModule :: Class -> [ImportDecl ()] -genImportInModule x = map (\y -> mkImport (getClassModuleBase x <.> y)) ["RawType", "Interface", "Implementation"] - -mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl () -mkImportWithDepCycles depCycles self imported = - let mloc = locateInDepCycles (self, imported) depCycles - in case mloc of - Just (idxSelf, idxImported) - | idxImported > idxSelf -> - mkImportSrc imported - _ -> mkImport imported - -genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()] -genImportInInterface isHsBoot depCycles m = - let modSelf = cmModule m <.> "Interface" - imported = cmImportedSubmodulesForInterface m - (rdepsU, rdepsD) = getCyclicDepSubmodules modSelf depCycles - in if isHsBoot - then -- for hs-boot file, we ignore all module imports in the cycle. - -- TODO: This is likely to be broken in more general cases. - -- Keep improving this as hs-boot allows. - - let imported' = fmap subModuleName imported L.\\ (rdepsU <> rdepsD) - in fmap mkImport imported' - else fmap (mkImportWithDepCycles depCycles modSelf . subModuleName) imported - --- OLD --- TODO: Remove -genImportInCast_ :: ClassModule -> [ImportDecl ()] -genImportInCast_ m = - fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m - --- NEW -genImportInCast :: ClassModule -> [Ex.ImportDecl Ex.GhcPs] -genImportInCast m = - fmap (Ex.mkImport . subModuleName) $ cmImportedSubmodulesForCast m - -genImportInImplementation :: ClassModule -> [ImportDecl ()] -genImportInImplementation m = - fmap (mkImport . subModuleName) $ cmImportedSubmodulesForImplementation m - --- | generate import list for a given top-level ordinary function --- currently this may generate duplicate import list. --- TODO: eliminate duplicated imports. --- TODO2: should be refactored out. -genImportForTLOrdinary :: TLOrdinary -> [ImportDecl ()] -genImportForTLOrdinary f = - let dep4func = extractClassDepForTLOrdinary f - ecs = returnDependency dep4func ++ argumentDependency dep4func - cmods = L.nub $ map getClassModuleBase $ rights ecs - tmods = L.nub $ map getTClassModuleBase $ lefts ecs - in concatMap (\x -> map (\y -> mkImport (x <.> y)) ["RawType", "Cast", "Interface"]) cmods - <> concatMap (\x -> map (\y -> mkImport (x <.> y)) ["Template"]) tmods - --- | generate import list for a given top-level template function --- currently this may generate duplicate import list. --- TODO: eliminate duplicated imports. --- TODO2: should be refactored out. -genImportForTLTemplate :: TLTemplate -> [ImportDecl ()] -genImportForTLTemplate f = - let dep4func = extractClassDepForTLTemplate f - ecs = returnDependency dep4func ++ argumentDependency dep4func - cmods = L.nub $ map getClassModuleBase $ rights ecs - tmods = L.nub $ map getTClassModuleBase $ lefts ecs - in concatMap (\x -> map (\y -> mkImport (x <.> y)) ["RawType", "Cast", "Interface"]) cmods - <> concatMap (\x -> map (\y -> mkImport (x <.> y)) ["Template"]) tmods - --- | generate import list for top level module -genImportInTopLevel :: - String -> - ([ClassModule], [TemplateClassModule]) -> - [ImportDecl ()] -genImportInTopLevel modname (mods, _tmods) = - map (mkImport . cmModule) mods - ++ map mkImport [modname <.> "Template", modname <.> "TH", modname <.> "Ordinary"] diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs new file mode 100644 index 00000000..4858f245 --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsImplementation + ( -- * import + genImportInImplementation, + + -- * functions + genHsFrontInst, + genHsFrontInstNew, + genHsFrontInstNonVirtual, + genHsFrontInstStatic, + genHsFrontInstVariables, + ) +where + +import Control.Monad.Reader (Reader) +import FFICXX.Generate.Code.Primitive + ( accessorSignature, + convertCpp2HS, + functionSignature, + hsFuncXformer, + ) +import FFICXX.Generate.Name + ( accessorName, + aliasedFuncName, + hsFuncName, + hscAccessorName, + hscFuncName, + subModuleName, + typeclassName, + ) +import FFICXX.Generate.Type.Annotate (AnnotateMap) +import FFICXX.Generate.Type.Class + ( Accessor (..), + Class (..), + Types (..), + isAbstractClass, + isNewFunc, + nonVirtualNotNewFuncs, + staticFuncs, + virtualFuncs, + ) +import FFICXX.Generate.Type.Module + ( ClassModule (..), + ) +-- +import FFICXX.Generate.Util.HaskellSrcExts + ( cxEmpty, + insDecl, + mkBind1, + mkFun, + mkImport, + mkInstance, + mkVar, + ) +import Language.Haskell.Exts.Build (app) +import Language.Haskell.Exts.Syntax + ( Decl, + ImportDecl, + ) + +-- +-- import +-- + +genImportInImplementation :: ClassModule -> [ImportDecl ()] +genImportInImplementation m = + fmap (mkImport . subModuleName) $ cmImportedSubmodulesForImplementation m + +-- +-- functions +-- + +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 :: + -- | only concrete class + Class -> + Reader AnnotateMap [Decl ()] +genHsFrontInstNew c = do + -- amap <- ask + let fs = filter isNewFunc (class_funcs c) + return . flip concatMap fs $ \f -> + let -- for the time being, let's ignore annotation. + -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap + -- newfuncann = mkComment 0 cann + rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) + in mkFun (aliasedFuncName c f) (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 + +genHsFrontInstVariables :: Class -> [Decl ()] +genHsFrontInstVariables c = + flip concatMap (class_vars c) $ \v -> + let rhs accessor = + app + (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1")) + (mkVar (hscAccessorName c v accessor)) + in mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing + <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing diff --git a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs new file mode 100644 index 00000000..93345ed1 --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsInterface + ( -- * import + genImportInInterface, + + -- * typeclass + genHsFrontDecl, + + -- * up/downcast + genHsFrontUpcastClass, + genHsFrontDowncastClass, + ) +where + +import Control.Monad.Reader (Reader) +import qualified Data.List as L +import FFICXX.Generate.Code.Primitive + ( classConstraints, + functionSignature, + ) +import FFICXX.Generate.Dependency.Graph + ( getCyclicDepSubmodules, + locateInDepCycles, + ) +import FFICXX.Generate.Name + ( hsClassName, + hsFuncName, + subModuleName, + typeclassName, + ) +import FFICXX.Generate.Type.Annotate (AnnotateMap) +import FFICXX.Generate.Type.Class + ( Class (..), + virtualFuncs, + ) +import FFICXX.Generate.Type.Module + ( ClassModule (..), + DepCycles, + ) +import FFICXX.Generate.Util.HaskellSrcExts + ( classA, + clsDecl, + cxTuple, + mkClass, + mkFun, + mkFunSig, + mkImport, + mkImportSrc, + mkPVar, + mkPVarSig, + mkTBind, + mkTVar, + mkVar, + pbind, + tyForall, + tyPtr, + tyapp, + tycon, + tyfun, + unkindedVar, + unqual, + ) +import Language.Haskell.Exts.Build (app, letE, name) +import Language.Haskell.Exts.Syntax + ( Decl, + ImportDecl, + ) +import System.FilePath ((<.>)) + +mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl () +mkImportWithDepCycles depCycles self imported = + let mloc = locateInDepCycles (self, imported) depCycles + in case mloc of + Just (idxSelf, idxImported) + | idxImported > idxSelf -> + mkImportSrc imported + _ -> mkImport imported + +genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()] +genImportInInterface isHsBoot depCycles m = + let modSelf = cmModule m <.> "Interface" + imported = cmImportedSubmodulesForInterface m + (rdepsU, rdepsD) = getCyclicDepSubmodules modSelf depCycles + in if isHsBoot + then -- for hs-boot file, we ignore all module imports in the cycle. + -- TODO: This is likely to be broken in more general cases. + -- Keep improving this as hs-boot allows. + + let imported' = fmap subModuleName imported L.\\ (rdepsU <> rdepsD) + in fmap mkImport imported' + else fmap (mkImportWithDepCycles depCycles modSelf . subModuleName) imported + +-- +-- typeclass declaration +-- + +genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ()) +genHsFrontDecl isHsBoot c = do + -- TODO: revive annotation + -- for the time being, let's ignore annotation. + -- amap <- ask + -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap + let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body + -- for hs-boot, we only have instance head. + cdecl' = mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] [] + sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) + body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c + if isHsBoot + then return cdecl' + else return cdecl + +------------ +-- upcast -- +------------ + +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") + +-------------- +-- downcast -- +-------------- + +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") diff --git a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs new file mode 100644 index 00000000..623e400e --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsTopLevel + ( -- * exports + genExport, + + -- * imports + genImportInModule, + genImportInTopLevel, + + -- * top-level decls and defs + genTopLevelDef, + genImportForTLOrdinary, + genImportForTLTemplate, + ) +where + +import Data.Either (lefts, rights) +import qualified Data.List as L +import FFICXX.Generate.Code.Primitive + ( CFunSig (..), + HsFunSig (..), + convertCpp2HS, + extractArgRetTypes, + ) +import FFICXX.Generate.Dependency + ( argumentDependency, + extractClassDepForTLOrdinary, + extractClassDepForTLTemplate, + returnDependency, + ) +import FFICXX.Generate.Name + ( aliasedFuncName, + getClassModuleBase, + getTClassModuleBase, + hsClassName, + hsFrontNameForTopLevel, + typeclassName, + ) +import FFICXX.Generate.Type.Class + ( Class (..), + TLOrdinary (..), + TLTemplate, + TopLevel (TLOrdinary), + constructorFuncs, + isAbstractClass, + isVirtualFunc, + nonVirtualNotNewFuncs, + staticFuncs, + ) +import FFICXX.Generate.Type.Module + ( ClassModule (..), + TemplateClassModule (..), + ) +import FFICXX.Generate.Util (toLowers) +-- +import FFICXX.Generate.Util.HaskellSrcExts + ( cxTuple, + eabs, + ethingall, + evar, + mkFun, + mkImport, + mkVar, + nonamespace, + tyForall, + tyapp, + tycon, + tyfun, + unqual, + ) +import Language.Haskell.Exts.Build (app) +import Language.Haskell.Exts.Syntax + ( Decl, + ExportSpec, + ImportDecl, + ) +import System.FilePath ((<.>)) + +-- +-- exports +-- + +------------ +-- Export -- +------------ + +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 + +-- | constructor and non-virtual function +genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()] +genExportConstructorAndNonvirtual c = map (evar . unqual) fns + where + fs = class_funcs c + fns = + map + (aliasedFuncName c) + ( constructorFuncs fs + <> nonVirtualNotNewFuncs fs + ) + +-- | staic function export list +genExportStatic :: Class -> [ExportSpec ()] +genExportStatic c = map (evar . unqual) fns + where + fs = class_funcs c + fns = map (aliasedFuncName c) (staticFuncs fs) + +-- +-- imports +-- + +-- | module summary re-exports +genImportInModule :: Class -> [ImportDecl ()] +genImportInModule x = map (\y -> mkImport (getClassModuleBase x <.> y)) ["RawType", "Interface", "Implementation"] + +-- | top=level +genImportInTopLevel :: + String -> + ([ClassModule], [TemplateClassModule]) -> + [ImportDecl ()] +genImportInTopLevel modname (mods, _tmods) = + map (mkImport . cmModule) mods + ++ map mkImport [modname <.> "Template", modname <.> "TH", modname <.> "Ordinary"] + +-- +-- declarations and definitions +-- + +genTopLevelDef :: TLOrdinary -> [Decl ()] +genTopLevelDef f@TopLevelFunction {..} = + let fname = hsFrontNameForTopLevel (TLOrdinary f) + HsFunSig typs assts = + extractArgRetTypes + Nothing + False + (CFunSig 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 +genTopLevelDef v@TopLevelVariable {..} = + let fname = hsFrontNameForTopLevel (TLOrdinary v) + cfname = "c_" <> toLowers fname + rtyp = convertCpp2HS Nothing toplevelvar_ret + sig = tyapp (tycon "IO") rtyp + rhs = app (mkVar "xformnull") (mkVar cfname) + in mkFun fname sig [] rhs Nothing + +-- | generate import list for a given top-level ordinary function +-- currently this may generate duplicate import list. +-- TODO: eliminate duplicated imports. +-- TODO2: should be refactored out. +genImportForTLOrdinary :: TLOrdinary -> [ImportDecl ()] +genImportForTLOrdinary f = + let dep4func = extractClassDepForTLOrdinary f + ecs = returnDependency dep4func ++ argumentDependency dep4func + cmods = L.nub $ map getClassModuleBase $ rights ecs + tmods = L.nub $ map getTClassModuleBase $ lefts ecs + in concatMap (\x -> map (\y -> mkImport (x <.> y)) ["RawType", "Cast", "Interface"]) cmods + <> concatMap (\x -> map (\y -> mkImport (x <.> y)) ["Template"]) tmods + +-- | generate import list for a given top-level template function +-- currently this may generate duplicate import list. +-- TODO: eliminate duplicated imports. +-- TODO2: should be refactored out. +genImportForTLTemplate :: TLTemplate -> [ImportDecl ()] +genImportForTLTemplate f = + let dep4func = extractClassDepForTLTemplate f + ecs = returnDependency dep4func ++ argumentDependency dep4func + cmods = L.nub $ map getClassModuleBase $ rights ecs + tmods = L.nub $ map getTClassModuleBase $ lefts ecs + in concatMap (\x -> map (\y -> mkImport (x <.> y)) ["RawType", "Cast", "Interface"]) cmods + <> concatMap (\x -> map (\y -> mkImport (x <.> y)) ["Template"]) tmods diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index df244fb1..6ee9cd80 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -32,32 +32,30 @@ import FFICXX.Generate.Code.Cpp import FFICXX.Generate.Code.HsCast ( genHsFrontInstCastable, genHsFrontInstCastableSelf, + genImportInCast, + ) +import FFICXX.Generate.Code.HsCommon + ( genExtraImport, + genExtraImport_, ) import FFICXX.Generate.Code.HsFFI ( genHsFFI, genImportInFFI, genTopLevelFFI_, ) -import FFICXX.Generate.Code.HsFrontEnd - ( genExport, - genExtraImport, - genExtraImport_, - genHsFrontDecl, - genHsFrontDowncastClass, - genHsFrontInst, +import FFICXX.Generate.Code.HsImplementation + ( genHsFrontInst, genHsFrontInstNew, genHsFrontInstNonVirtual, genHsFrontInstStatic, genHsFrontInstVariables, - genHsFrontUpcastClass, - genImportForTLOrdinary, - genImportForTLTemplate, - genImportInCast, genImportInImplementation, + ) +import FFICXX.Generate.Code.HsInterface + ( genHsFrontDecl, + genHsFrontDowncastClass, + genHsFrontUpcastClass, genImportInInterface, - genImportInModule, - genImportInTopLevel, - genTopLevelDef, ) import FFICXX.Generate.Code.HsProxy (genProxyInstance) import FFICXX.Generate.Code.HsRawType (hsClassRawType) @@ -72,6 +70,14 @@ import FFICXX.Generate.Code.HsTemplate genTmplInstance, genTmplInterface, ) +import FFICXX.Generate.Code.HsTopLevel + ( genExport, + genImportForTLOrdinary, + genImportForTLTemplate, + genImportInModule, + genImportInTopLevel, + genTopLevelDef, + ) import FFICXX.Generate.Dependency ( class_allparents, mkDaughterMap, From be4879dc7b86b4e737c54e833182df174354b5ae Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Fri, 11 Aug 2023 14:26:23 -0700 Subject: [PATCH 07/19] typeclass interface generation via ghc-exactprint (#217) HsInterface and HsImplementation is fully converted. Note: template member functions are disabled for now. will be reinstated in the following PRs. * mkClass * mkImportSrc * convert genHsFrontDecl * converted cxx2HsType, extractArgRetType', functionSignature', tyForall, qualTy * implemented mkPVarSig, pbind, letE, valBinds, toLocalBinds * now genHsFrontUpcastClass is converted. * HsInterface is fully converted * correct formatting. stdcxx is buildable with generated code! * mark old code using O, in HsImplementation * genImportInImplementation converted * genHsFrontInst converted * remove the old genExtraImport_ and genImportInCast_ * accessorSignature converted * converted all functions in HsImplementation * remove old imports. * format fix --- fficxx/src/FFICXX/Generate/Builder.hs | 9 +- fficxx/src/FFICXX/Generate/Code/HsCommon.hs | 32 +-- .../FFICXX/Generate/Code/HsImplementation.hs | 49 ++-- .../src/FFICXX/Generate/Code/HsInterface.hs | 100 +++++--- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 142 +++++++++++- fficxx/src/FFICXX/Generate/ContentMaker.hs | 132 +++++------ .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 217 ++++++++++++++---- 7 files changed, 462 insertions(+), 219 deletions(-) diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index b0e9b983..b5efdd21 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -172,7 +172,7 @@ simpleBuilder cfg sbc = do for_ mods $ \m -> gen (cmModule m <.> "Interface" <.> "hs") - (prettyPrint (C.buildInterfaceHs mempty depCycles m)) + (exactPrint (C.buildInterfaceHs mempty depCycles m)) -- putStrLn "Generating Cast.hs" for_ mods $ \m -> @@ -181,10 +181,11 @@ simpleBuilder cfg sbc = do (exactPrint (C.buildCastHs m)) -- putStrLn "Generating Implementation.hs" - for_ mods $ \m -> + for_ mods $ \m -> do + debugExactPrint (C.buildImplementationHs mempty m) gen (cmModule m <.> "Implementation" <.> "hs") - (prettyPrint (C.buildImplementationHs mempty m)) + (exactPrint (C.buildImplementationHs mempty m)) -- putStrLn "Generating Proxy.hs" for_ mods $ \m -> @@ -214,7 +215,7 @@ simpleBuilder cfg sbc = do for_ hsbootlst $ \m -> do gen (cmModule m <.> "Interface" <.> "hs-boot") - (hsBootHackClearEmptyContexts $ prettyPrint (C.buildInterfaceHsBoot depCycles m)) + (hsBootHackClearEmptyContexts $ exactPrint (C.buildInterfaceHsBoot depCycles m)) -- putStrLn "Generating Module summary file" for_ mods $ \m -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsCommon.hs b/fficxx/src/FFICXX/Generate/Code/HsCommon.hs index 9476eaba..eaf65edc 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCommon.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCommon.hs @@ -1,32 +1,12 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module FFICXX.Generate.Code.HsCommon - ( genExtraImport_, - genExtraImport, - genImportInCast_, + ( genExtraImport, ) where -import FFICXX.Generate.Name (subModuleName) import FFICXX.Generate.Type.Module (ClassModule (..)) -import qualified FFICXX.Generate.Util.GHCExactPrint as Ex -import FFICXX.Generate.Util.HaskellSrcExts (mkImport) -import qualified GHC.Hs as Ex -import Language.Haskell.Exts.Syntax (ImportDecl) - --- TODO: Remove -genExtraImport_ :: ClassModule -> [ImportDecl ()] -genExtraImport_ cm = map mkImport (cmExtraImport cm) - --- This is the new version. -genExtraImport :: ClassModule -> [Ex.ImportDecl Ex.GhcPs] -genExtraImport cm = fmap Ex.mkImport (cmExtraImport cm) +import FFICXX.Generate.Util.GHCExactPrint (mkImport) +import GHC.Hs (GhcPs) +import Language.Haskell.Syntax (ImportDecl) --- OLD --- TODO: Remove -genImportInCast_ :: ClassModule -> [ImportDecl ()] -genImportInCast_ m = - fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m +genExtraImport :: ClassModule -> [ImportDecl GhcPs] +genExtraImport cm = fmap mkImport (cmExtraImport cm) diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs index 4858f245..7d53535c 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs @@ -19,8 +19,8 @@ where import Control.Monad.Reader (Reader) import FFICXX.Generate.Code.Primitive ( accessorSignature, - convertCpp2HS, - functionSignature, + cxx2HsType, + functionSignature', hsFuncXformer, ) import FFICXX.Generate.Name @@ -43,30 +43,25 @@ import FFICXX.Generate.Type.Class staticFuncs, virtualFuncs, ) -import FFICXX.Generate.Type.Module - ( ClassModule (..), - ) --- -import FFICXX.Generate.Util.HaskellSrcExts - ( cxEmpty, - insDecl, +import FFICXX.Generate.Type.Module (ClassModule (..)) +import FFICXX.Generate.Util.GHCExactPrint + ( app, + cxEmpty, + instD, mkBind1, mkFun, mkImport, mkInstance, mkVar, ) -import Language.Haskell.Exts.Build (app) -import Language.Haskell.Exts.Syntax - ( Decl, - ImportDecl, - ) +import GHC.Hs (GhcPs) +import Language.Haskell.Syntax (HsDecl, ImportDecl) -- -- import -- -genImportInImplementation :: ClassModule -> [ImportDecl ()] +genImportInImplementation :: ClassModule -> [ImportDecl GhcPs] genImportInImplementation m = fmap (mkImport . subModuleName) $ cmImportedSubmodulesForImplementation m @@ -74,46 +69,46 @@ genImportInImplementation m = -- functions -- -genHsFrontInst :: Class -> Class -> [Decl ()] +genHsFrontInst :: Class -> Class -> [HsDecl GhcPs] genHsFrontInst parent child | (not . isAbstractClass) child = - let idecl = mkInstance cxEmpty (typeclassName parent) [convertCpp2HS (Just child) SelfType] body + let idecl = mkInstance cxEmpty (typeclassName parent) [cxx2HsType (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] + body = map defn . virtualFuncs . class_funcs $ parent + in [instD idecl] | otherwise = [] genHsFrontInstNew :: -- | only concrete class Class -> - Reader AnnotateMap [Decl ()] + Reader AnnotateMap [HsDecl GhcPs] genHsFrontInstNew c = do -- amap <- ask let fs = filter isNewFunc (class_funcs c) - return . flip concatMap fs $ \f -> + pure . flip concatMap fs $ \f -> let -- for the time being, let's ignore annotation. -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap -- newfuncann = mkComment 0 cann rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) - in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing + in mkFun (aliasedFuncName c f) (functionSignature' c f) [] rhs Nothing -genHsFrontInstNonVirtual :: Class -> [Decl ()] +genHsFrontInstNonVirtual :: Class -> [HsDecl GhcPs] 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 + in mkFun (aliasedFuncName c f) (functionSignature' c f) [] rhs Nothing where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) -genHsFrontInstStatic :: Class -> [Decl ()] +genHsFrontInstStatic :: Class -> [HsDecl GhcPs] 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 + in mkFun (aliasedFuncName c f) (functionSignature' c f) [] rhs Nothing -genHsFrontInstVariables :: Class -> [Decl ()] +genHsFrontInstVariables :: Class -> [HsDecl GhcPs] genHsFrontInstVariables c = flip concatMap (class_vars c) $ \v -> let rhs accessor = diff --git a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs index 93345ed1..7929c491 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs @@ -18,9 +18,10 @@ where import Control.Monad.Reader (Reader) import qualified Data.List as L +import qualified Data.List.NonEmpty as NE import FFICXX.Generate.Code.Primitive ( classConstraints, - functionSignature, + functionSignature', ) import FFICXX.Generate.Dependency.Graph ( getCyclicDepSubmodules, @@ -41,10 +42,11 @@ import FFICXX.Generate.Type.Module ( ClassModule (..), DepCycles, ) -import FFICXX.Generate.Util.HaskellSrcExts - ( classA, - clsDecl, +import FFICXX.Generate.Util.GHCExactPrint + ( app, + classA, cxTuple, + letE, mkClass, mkFun, mkFunSig, @@ -56,22 +58,25 @@ import FFICXX.Generate.Util.HaskellSrcExts mkTVar, mkVar, pbind, + qualTy, + toLocalBinds, tyForall, tyPtr, tyapp, tycon, tyfun, - unkindedVar, - unqual, + valBinds, ) -import Language.Haskell.Exts.Build (app, letE, name) -import Language.Haskell.Exts.Syntax - ( Decl, +import GHC.Hs (GhcPs) +import Language.Haskell.Syntax + ( HsDecl (TyClD), + HsLocalBindsLR (EmptyLocalBinds), ImportDecl, + noExtField, ) import System.FilePath ((<.>)) -mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl () +mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl GhcPs mkImportWithDepCycles depCycles self imported = let mloc = locateInDepCycles (self, imported) depCycles in case mloc of @@ -80,7 +85,7 @@ mkImportWithDepCycles depCycles self imported = mkImportSrc imported _ -> mkImport imported -genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()] +genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl GhcPs] genImportInInterface isHsBoot depCycles m = let modSelf = cmModule m <.> "Interface" imported = cmImportedSubmodulesForInterface m @@ -98,17 +103,17 @@ genImportInInterface isHsBoot depCycles m = -- typeclass declaration -- -genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ()) +genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (HsDecl GhcPs) genHsFrontDecl isHsBoot c = do -- TODO: revive annotation -- for the time being, let's ignore annotation. -- amap <- ask -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap - let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body + let cdecl = TyClD noExtField (mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body) -- for hs-boot, we only have instance head. - cdecl' = mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] [] - sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) - body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c + cdecl' = TyClD noExtField (mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] []) + sigdecl f = mkFunSig (hsFuncName c f) (functionSignature' c f) + body = map sigdecl . virtualFuncs . class_funcs $ c if isHsBoot then return cdecl' else return cdecl @@ -117,50 +122,71 @@ genHsFrontDecl isHsBoot c = do -- upcast -- ------------ -genHsFrontUpcastClass :: Class -> [Decl ()] -genHsFrontUpcastClass c = mkFun ("upcast" <> highname) typ [mkPVar "h"] rhs Nothing +genHsFrontUpcastClass :: Class -> [HsDecl GhcPs] +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_bind = mkTBind "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) + (NE.singleton a_bind) + ( qualTy + (cxTuple [classA "FPtr" [a_tvar], classA 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 - ] + ( toLocalBinds $ + valBinds + [ pbind + (mkPVar "fh") + (app (mkVar "get_fptr") (mkVar "h")) + (EmptyLocalBinds noExtField), + pbind + (mkPVarSig "fh2" (tyapp tyPtr rawtype)) + (app (mkVar "castPtr") (mkVar "fh")) + (EmptyLocalBinds noExtField) + ] + ) (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") -------------- -- downcast -- -------------- -genHsFrontDowncastClass :: Class -> [Decl ()] -genHsFrontDowncastClass c = mkFun ("downcast" <> highname) typ [mkPVar "h"] rhs Nothing +genHsFrontDowncastClass :: Class -> [HsDecl GhcPs] +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_bind = mkTBind "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) + (NE.singleton a_bind) + ( qualTy + (cxTuple [classA "FPtr" [a_tvar], classA 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 - ] + ( toLocalBinds $ + valBinds + [ pbind + (mkPVar "fh") + (app (mkVar "get_fptr") (mkVar "h")) + (EmptyLocalBinds noExtField), + pbind + (mkPVar "fh2") + (app (mkVar "castPtr") (mkVar "fh")) + (EmptyLocalBinds noExtField) + ] + ) (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 3df453d1..74abc54e 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -56,11 +56,11 @@ import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) import GHC.Hs (GhcPs) import Language.Haskell.Exts.Syntax ( Asst, - Context, Type, ) import Language.Haskell.Syntax - ( HsType, + ( HsContext, + HsType, ) data CFunSig = CFunSig @@ -68,11 +68,18 @@ data CFunSig = CFunSig cRetType :: Types } +-- | OLD data HsFunSig = HsFunSig { hsSigTypes :: [Type ()], hsSigConstraints :: [Asst ()] } +-- | NEW +data HsFunSig' = HsFunSig' + { hsSig'Types :: [HsType GhcPs], + hsSig'Constraints :: [HsType GhcPs] + } + ctypToCType :: CTypes -> IsConst -> R.CType Identity ctypToCType ctyp isconst = let typ = case ctyp of @@ -771,6 +778,7 @@ c2HsType (CEnum t _) = c2HsType t c2HsType (CPointer t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) c2HsType (CRef t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) +-- OLD convertCpp2HS :: Maybe Class -> Types -> Type () convertCpp2HS _c Void = unit_tycon convertCpp2HS (Just c) SelfType = tycon ((fst . hsClassName) c) @@ -798,6 +806,34 @@ convertCpp2HS _c (TemplateType t) = convertCpp2HS _c (TemplateParam p) = mkTVar p convertCpp2HS _c (TemplateParamPointer p) = mkTVar p +-- NEW +cxx2HsType :: Maybe Class -> Types -> HsType GhcPs +cxx2HsType _c Void = Ex.unit_tycon +cxx2HsType (Just c) SelfType = Ex.tycon ((fst . hsClassName) c) +cxx2HsType Nothing SelfType = error "cxx2HsType : SelfType but no class " +cxx2HsType _c (CT t _) = c2HsType t +cxx2HsType _c (CPT (CPTClass c') _) = (Ex.tycon . fst . hsClassName) c' +cxx2HsType _c (CPT (CPTClassRef c') _) = (Ex.tycon . fst . hsClassName) c' +cxx2HsType _c (CPT (CPTClassCopy c') _) = (Ex.tycon . fst . hsClassName) c' +cxx2HsType _c (CPT (CPTClassMove c') _) = (Ex.tycon . fst . hsClassName) c' +cxx2HsType _c (TemplateApp x) = + foldl1 Ex.tyapp $ + map Ex.tycon $ + tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) +cxx2HsType _c (TemplateAppRef x) = + foldl1 Ex.tyapp $ + map Ex.tycon $ + tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) +cxx2HsType _c (TemplateAppMove x) = + foldl1 Ex.tyapp $ + map Ex.tycon $ + tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) +cxx2HsType _c (TemplateType t) = + foldl1 Ex.tyapp $ + Ex.tycon (tclass_name t) : map Ex.mkTVar (tclass_params t) +cxx2HsType _c (TemplateParam p) = Ex.mkTVar p +cxx2HsType _c (TemplateParamPointer p) = Ex.mkTVar p + convertCpp2HS4Tmpl :: -- | self Type () -> @@ -845,9 +881,11 @@ hsFuncXformer func = let len = length (genericFuncArgs func) in "xform" <> show len -classConstraints :: Class -> Context () -classConstraints = cxTuple . map ((\n -> classA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents +classConstraints :: Class -> HsContext GhcPs +classConstraints = + Ex.cxTuple . map ((\name -> Ex.classA name [Ex.mkTVar "a"]) . typeclassName) . class_parents +-- OLD extractArgRetTypes :: -- | class (Nothing for top-level function) Maybe Class -> @@ -912,6 +950,77 @@ extractArgRetTypes mc isvirtual (CFunSig args ret) = Void -> return unit_tycon _ -> error ("No such c type : " <> show typ) +-- NEW +extractArgRetTypes' :: + -- | class (Nothing for top-level function) + Maybe Class -> + -- | is virtual function? + Bool -> + -- | C type signature information for a given function: + -- (argument types, return type) of a given function + CFunSig -> + -- | Haskell type signature information for the function: + -- (types, class constraints) + HsFunSig' +extractArgRetTypes' mc isvirtual (CFunSig args ret) = + let (typs, s) = flip runState ([], (0 :: Int)) $ do + as <- mapM (mktyp . arg_type) args + r <- case ret of + SelfType -> case mc of + Nothing -> error "extractArgRetTypes: SelfType return but no class" + Just c -> + if isvirtual + then return (Ex.mkTVar "a") + else return $ Ex.tycon ((fst . hsClassName) c) + x -> (return . cxx2HsType Nothing) x + return (as ++ [Ex.tyapp (Ex.tycon "IO") r]) + in HsFunSig' + { hsSig'Types = typs, + hsSig'Constraints = fst s + } + where + addclass c = do + (ctxts, n) <- get + let cname = (fst . hsClassName) c + iname = typeclassNameFromStr cname + tvar = Ex.mkTVar ('c' : show n) + ctxt1 = Ex.classA iname [tvar] + ctxt2 = Ex.classA "FPtr" [tvar] + put (ctxt1 : ctxt2 : ctxts, n + 1) + return tvar + addstring = do + (ctxts, n) <- get + let tvar = Ex.mkTVar ('c' : show n) + ctxt = Ex.classA "Castable" [tvar, Ex.tycon "CString"] + put (ctxt : ctxts, n + 1) + return tvar + mktyp typ = + case typ of + SelfType -> return (Ex.mkTVar "a") + CT CTString Const -> addstring + CT _ _ -> return $ cxx2HsType Nothing typ + CPT (CPTClass c') _ -> addclass c' + CPT (CPTClassRef c') _ -> addclass c' + CPT (CPTClassCopy c') _ -> addclass c' + CPT (CPTClassMove c') _ -> addclass c' + -- it is not clear whether the following is okay or not. + (TemplateApp x) -> + pure $ + cxx2HsType Nothing (TemplateApp x) + (TemplateAppRef x) -> + pure $ + cxx2HsType Nothing (TemplateAppRef x) + (TemplateAppMove x) -> + pure $ + cxx2HsType Nothing (TemplateAppMove x) + (TemplateType t) -> + pure $ + foldl1 Ex.tyapp (Ex.tycon (tclass_name t) : map Ex.mkTVar (tclass_params t)) + (TemplateParam p) -> pure (Ex.mkTVar p) + Void -> pure Ex.unit_tycon + _ -> error ("No such c type : " <> show typ) + +-- OLD functionSignature :: Class -> Function -> Type () functionSignature c f = let HsFunSig typs assts = @@ -926,6 +1035,21 @@ functionSignature c f = | otherwise = id in tyForall Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) +-- NEW +functionSignature' :: Class -> Function -> HsType GhcPs +functionSignature' c f = + let HsFunSig' typs assts = + extractArgRetTypes' + (Just c) + (isVirtualFunc f) + (CFunSig (genericFuncArgs f) (genericFuncRet f)) + ctxt = Ex.cxTuple assts + arg0 + | isVirtualFunc f = (Ex.mkTVar "a" :) + | isNonVirtualFunc f = (Ex.mkTVar (fst (hsClassName c)) :) + | otherwise = id + in Ex.qualTy ctxt (foldr1 Ex.tyfun (arg0 typs)) + functionSignatureT :: TemplateClass -> TemplateFunction -> Type () functionSignatureT t TFun {..} = let (hname, _) = hsTemplateClassName t @@ -997,13 +1121,13 @@ accessorCFunSig :: Types -> Accessor -> CFunSig accessorCFunSig typ Getter = CFunSig [] typ accessorCFunSig typ Setter = CFunSig [Arg typ "x"] Void -accessorSignature :: Class -> Variable -> Accessor -> Type () +accessorSignature :: Class -> Variable -> Accessor -> HsType GhcPs accessorSignature c v accessor = let csig = accessorCFunSig (arg_type (unVariable v)) accessor - HsFunSig typs assts = extractArgRetTypes (Just c) False csig - ctxt = cxTuple assts - arg0 = (mkTVar (fst (hsClassName c)) :) - in tyForall Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) + HsFunSig' typs assts = extractArgRetTypes' (Just c) False csig + ctxt = Ex.cxTuple assts + arg0 = (Ex.mkTVar (fst (hsClassName c)) :) + in Ex.qualTy ctxt (foldr1 Ex.tyfun (arg0 typs)) -- | old function. this is for FFI type. hsFFIFuncTyp :: Maybe (Selfness, Class) -> CFunSig -> Type () diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 6ee9cd80..d9c43814 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -36,7 +36,6 @@ import FFICXX.Generate.Code.HsCast ) import FFICXX.Generate.Code.HsCommon ( genExtraImport, - genExtraImport_, ) import FFICXX.Generate.Code.HsFFI ( genHsFFI, @@ -388,71 +387,66 @@ buildInterfaceHs :: AnnotateMap -> DepCycles -> ClassModule -> - Module () + HsModule GhcPs buildInterfaceHs amap depCycles m = - mkModule + Ex.mkModule (cmModule m <.> "Interface") - [ lang - [ "EmptyDataDecls", - "ExistentialQuantification", - "FlexibleContexts", - "FlexibleInstances", - "ForeignFunctionInterface", - "MultiParamTypeClasses", - "ScopedTypeVariables", - "TypeFamilies", - "TypeSynonymInstances" - ] + [ "EmptyDataDecls", + "ExistentialQuantification", + "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "MultiParamTypeClasses", + "ScopedTypeVariables", + "TypeFamilies", + "TypeSynonymInstances" ] ifaceImports ifaceBody where classes = [cihClass (cmCIH m)] ifaceImports = - [ mkImport "Data.Word", - mkImport "Data.Int", - mkImport "Foreign.C", - mkImport "Foreign.Ptr", - mkImport "FFICXX.Runtime.Cast" + [ Ex.mkImport "Data.Word", + Ex.mkImport "Data.Int", + Ex.mkImport "Foreign.C", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport "FFICXX.Runtime.Cast" ] <> genImportInInterface False depCycles m - <> genExtraImport_ m + <> genExtraImport m ifaceBody = runReader (mapM (genHsFrontDecl False) classes) amap <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes -buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module () +buildInterfaceHsBoot :: DepCycles -> ClassModule -> HsModule GhcPs buildInterfaceHsBoot depCycles m = - mkModule + Ex.mkModule (cmModule m <.> "Interface") - [ lang - [ "EmptyDataDecls", - "ExistentialQuantification", - "FlexibleContexts", - "FlexibleInstances", - "ForeignFunctionInterface", - "MultiParamTypeClasses", - "ScopedTypeVariables", - "TypeFamilies", - "TypeSynonymInstances" - ] + [ "EmptyDataDecls", + "ExistentialQuantification", + "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "MultiParamTypeClasses", + "ScopedTypeVariables", + "TypeFamilies", + "TypeSynonymInstances" ] hsbootImports hsbootBody where c = cihClass (cmCIH m) hsbootImports = - [ mkImport "Data.Word", - mkImport "Data.Int", - mkImport "Foreign.C", - mkImport "Foreign.Ptr", - mkImport "FFICXX.Runtime.Cast" + [ Ex.mkImport "Data.Word", + Ex.mkImport "Data.Int", + Ex.mkImport "Foreign.C", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport "FFICXX.Runtime.Cast" ] <> genImportInInterface True depCycles m - <> genExtraImport_ m - hsbootBody = - runReader (mapM (genHsFrontDecl True) [c]) M.empty + <> genExtraImport m + hsbootBody = runReader (mapM (genHsFrontDecl True) [c]) M.empty buildCastHs :: ClassModule -> HsModule GhcPs buildCastHs m = @@ -479,43 +473,42 @@ buildCastHs m = mapMaybe genHsFrontInstCastable classes <> mapMaybe genHsFrontInstCastableSelf classes -buildImplementationHs :: AnnotateMap -> ClassModule -> Module () +buildImplementationHs :: AnnotateMap -> ClassModule -> HsModule GhcPs buildImplementationHs amap m = - mkModule + Ex.mkModule (cmModule m <.> "Implementation") - [ lang - [ "EmptyDataDecls", - "FlexibleContexts", - "FlexibleInstances", - "ForeignFunctionInterface", - "IncoherentInstances", - "MultiParamTypeClasses", - "OverlappingInstances", - "TemplateHaskell", - "TypeFamilies", - "TypeSynonymInstances" - ] + [ "EmptyDataDecls", + "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "IncoherentInstances", + "MultiParamTypeClasses", + "OverlappingInstances", + "TemplateHaskell", + "TypeFamilies", + "TypeSynonymInstances" ] implImports implBody where classes = [cihClass (cmCIH m)] implImports = - [ mkImport "Data.Monoid", -- for template member - mkImport "Data.Word", - mkImport "Data.Int", - mkImport "Foreign.C", - mkImport "Foreign.Ptr", - mkImport "Language.Haskell.TH", -- for template member - mkImport "Language.Haskell.TH.Syntax", -- for template member - mkImport "System.IO.Unsafe", - mkImport "FFICXX.Runtime.Cast", - mkImport "FFICXX.Runtime.CodeGen.Cxx", -- for template member - mkImport "FFICXX.Runtime.TH" -- for template member + [ Ex.mkImport "Data.Monoid", -- for template member + Ex.mkImport "Data.Word", + Ex.mkImport "Data.Int", + Ex.mkImport "Foreign.C", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport "Language.Haskell.TH", -- for template member + Ex.mkImport "Language.Haskell.TH.Syntax", -- for template member + Ex.mkImport "System.IO.Unsafe", + Ex.mkImport "FFICXX.Runtime.Cast", + Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", -- for template member + Ex.mkImport "FFICXX.Runtime.TH" -- for template member ] <> genImportInImplementation m - <> genExtraImport_ m - f :: Class -> [Decl ()] + <> genExtraImport m + + f :: Class -> [HsDecl GhcPs] f y = concatMap (flip genHsFrontInst y) (y : class_allparents y) implBody = concatMap f classes @@ -523,7 +516,8 @@ buildImplementationHs amap m = <> concatMap genHsFrontInstNonVirtual classes <> concatMap genHsFrontInstStatic classes <> concatMap genHsFrontInstVariables classes - <> genTemplateMemberFunctions (cmCIH m) + +-- <> genTemplateMemberFunctions (cmCIH m) buildProxyHs :: ClassModule -> HsModule GhcPs buildProxyHs m = diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index 9fa1ecd4..65f1036d 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -7,6 +7,7 @@ module FFICXX.Generate.Util.GHCExactPrint -- * import and FFI mkImport, + mkImportSrc, mkForImpCcall, -- * names @@ -14,6 +15,8 @@ module FFICXX.Generate.Util.GHCExactPrint -- * types mkTVar, + tyForall, + qualTy, tyapp, tycon, tyfun, @@ -21,6 +24,7 @@ module FFICXX.Generate.Util.GHCExactPrint tyParen, tyPtr, unit_tycon, + mkTBind, -- * data/newtype declaration mkData, @@ -37,12 +41,14 @@ module FFICXX.Generate.Util.GHCExactPrint cxEmpty, cxTuple, classA, + mkClass, mkInstance, mkTypeFamInst, instD, -- * pattern mkPVar, + mkPVarSig, pApp, parP, @@ -51,36 +57,33 @@ module FFICXX.Generate.Util.GHCExactPrint con, doE, inapp, + letE, listE, mkVar, op, par, strE, + valBinds, + toLocalBinds, -- * stmt mkBodyStmt, + pbind, {- app', conDecl, qualConDecl, recDecl, lit, mkTVar, - mkPVar, mkIVar, - mkPVarSig, - pbind, pbind_, - mkTBind, - mkClass, dhead, mkDeclHead, - mkInstance, mkModuleE, mkImportExp, mkImportSrc, lang, dot, - tyForall, tyParen, tyForeignPtr, classA, @@ -101,7 +104,6 @@ module FFICXX.Generate.Util.GHCExactPrint insDecl, generator, qualifier, - clsDecl, unkindedVar, if_, urhs, @@ -113,10 +115,11 @@ module FFICXX.Generate.Util.GHCExactPrint ) where +import Data.Foldable (toList) import Data.List (foldl') -import Data.Maybe (maybeToList) +import Data.List.NonEmpty (NonEmpty) import Data.String (IsString (fromString)) -import GHC.Data.Bag (listToBag) +import GHC.Data.Bag (emptyBag, listToBag) import GHC.Hs ( AnnSig (..), AnnsModule (..), @@ -204,28 +207,33 @@ import Language.Haskell.Syntax GRHSs (..), HsArg (..), HsArrow (..), - HsBind (..), + HsBind, HsBindLR (..), HsConDetails (PrefixCon), - HsContext (..), + HsContext, HsDataDefn (..), HsDecl (..), - HsDeriving (..), + HsDeriving, HsDerivingClause (..), HsDoFlavour (..), HsExpr (..), + HsForAllTelescope (..), HsLit (..), HsLocalBinds, HsLocalBindsLR (..), HsMatchContext (FunRhs), HsModule (..), HsOuterTyVarBndrs (HsOuterImplicit), + HsPatSigType (..), HsScaled (..), HsSigType (..), HsToken (..), HsTupleSort (..), + HsTyVarBndr (UserTyVar), HsType (..), HsUniToken (..), + HsValBinds, + HsValBindsLR (..), HsWildCardBndrs (HsWC), ImportDecl (..), ImportDeclQualifiedStyle (..), @@ -265,12 +273,24 @@ tokLoc :: Int -> TokenLocation tokLoc nLines = TokenLoc (mkEpaDelta nLines) mkRelAnchor :: Int -> Anchor -mkRelAnchor nLines = +mkRelAnchor nLines = mkRelAnchor' (mkDeltaPos nLines) + +-- let a' = spanAsAnchor defSrcSpan +-- in a' {anchor_op = MovedAnchor (mkDeltaPos nLines)} + +mkRelAnchor' :: DeltaPos -> Anchor +mkRelAnchor' delta = let a' = spanAsAnchor defSrcSpan - in a' {anchor_op = MovedAnchor (mkDeltaPos nLines)} + in a' {anchor_op = MovedAnchor delta} mkRelEpAnn :: Int -> ann -> EpAnn ann -mkRelEpAnn nLines ann = EpAnn (mkRelAnchor nLines) ann emptyComments +mkRelEpAnn nLines = mkRelEpAnn' (mkDeltaPos nLines) + +-- EpAnn (mkRelAnchor nLines) ann emptyComments + +mkRelEpAnn' :: DeltaPos -> ann -> EpAnn ann +mkRelEpAnn' delta ann = + EpAnn (mkRelAnchor' delta) ann emptyComments mkRelSrcSpanAnn :: Int -> ann -> SrcAnn ann mkRelSrcSpanAnn nLines ann = @@ -393,6 +413,24 @@ mkImport name = where modName = ModuleName (fromString name) +mkImportSrc :: + -- | Module name + String -> + ImportDecl GhcPs +mkImportSrc name = + ImportDecl + { ideclExt = XImportDeclPass noAnn NoSourceText False, + ideclName = L (mkRelSrcSpanAnn 0 (AnnListItem [])) modName, + ideclPkgQual = NoRawPkgQual, + ideclSource = IsBoot, + ideclSafe = False, + ideclQualified = NotQualified, + ideclAs = Nothing, + ideclImportList = Nothing + } + where + modName = ModuleName (fromString name) + -- NOTE: Unfortunately, the location annotation of GHC API for foreign import is not fully relative, -- i.e. we cannot place correct spaces between "import", "ccall" and "safe", and the generated result -- is not a valid Haskell code. So as a workaround we need to put a place holder in comment. @@ -456,6 +494,40 @@ mkLIdP nLines name = L (mkRelSrcSpanAnn nLines (NameAnnTrailing [])) id' -- types -- +tyForall :: + NonEmpty (HsTyVarBndr () GhcPs) -> + HsType GhcPs -> + HsType GhcPs +tyForall tbnds typ = + HsForAllTy + { hst_xforall = noExtField, + hst_tele = tele, + hst_body = mkL (-1) typ + } + where + ann = (AddEpAnn AnnForall (mkEpaDelta (-1)), AddEpAnn AnnDot (mkEpaDelta (-1))) + tele = HsForAllVis (mkRelEpAnn (-1) ann) (fmap (mkL 0) $ toList tbnds) + +qualTy :: + HsContext GhcPs -> + HsType GhcPs -> + HsType GhcPs +qualTy ctxt typ = + HsQualTy + { hst_xqual = noExtField, + hst_ctxt = L (mkRelSrcSpanAnn (-1) annCtxt) ctxt, + hst_body = mkL 0 typ + } + where + annCtxt + | null ctxt = AnnContext Nothing [] [] + | otherwise = + AnnContext + { ac_darrow = Just (NormalSyntax, mkEpaDelta 0), + ac_open = [mkEpaDelta 0], + ac_close = [mkEpaDelta (-1)] + } + tycon :: String -> HsType GhcPs tycon name = HsTyVar @@ -481,7 +553,7 @@ tyfun x y = HsFunTy ann arrow lx ly where ann = mkRelEpAnn (-1) NoEpAnns - arrow = HsUnrestrictedArrow (L (tokLoc (-1)) HsNormalTok) + arrow = HsUnrestrictedArrow (L (tokLoc 0) HsNormalTok) lx = mkL (-1) x ly = mkL 0 y @@ -514,6 +586,9 @@ unit_tycon = where ann = AnnParen AnnParens (mkEpaDelta (-1)) (mkEpaDelta (-1)) +mkTBind :: String -> HsTyVarBndr () GhcPs +mkTBind name = UserTyVar (mkRelEpAnn (-1) []) () (mkLIdP (-1) name) + -- -- data/newtype declaration -- @@ -634,7 +709,7 @@ mkFun :: -- | decls [HsDecl GhcPs] mkFun fname typ pats rhs mbinds = - [ mkFunSig fname typ, + [ SigD noExtField (mkFunSig fname typ), ValD noExtField (mkBind1 fname pats rhs mbinds) ] @@ -642,9 +717,9 @@ mkFunSig :: -- | function name String -> HsType GhcPs -> - HsDecl GhcPs + Sig GhcPs mkFunSig fname typ = - SigD noExtField (TypeSig ann [lid] bndr) + TypeSig ann [lid] bndr where ann = mkRelEpAnn (-1) (AnnSig (AddEpAnn AnnDcolon (mkEpaDelta 0)) []) @@ -702,9 +777,9 @@ tupleAnn xs = lastX = last xs xs'' = fmap - (L (mkRelSrcSpanAnn (-1) (AnnListItem [AddCommaAnn (mkEpaDelta (-1))]))) + (L (mkRelSrcSpanAnn 0 (AnnListItem [AddCommaAnn (mkEpaDelta (-1))]))) xs' - in (xs'' ++ [mkL (-1) lastX]) + in (xs'' ++ [mkL 0 lastX]) -- -- Typeclass @@ -721,6 +796,41 @@ classA name typs = foldl' tyapp (tycon name) typs' where typs' = fmap tyParen typs +mkClass :: + HsContext GhcPs -> + String -> + [HsTyVarBndr () GhcPs] -> + [Sig GhcPs] -> + TyClDecl GhcPs +mkClass ctxt name tbnds sigs = + ClassDecl + { tcdCExt = (mkRelEpAnn (-1) annos, NoAnnSortKey), + tcdLayout = VirtualBraces 2, + tcdCtxt = Just (L (mkRelSrcSpanAnn 0 annCtxt) ctxt), + tcdLName = mkLIdP 0 name, + tcdTyVars = HsQTvs noExtField $ fmap (mkL 0) tbnds, + tcdFixity = Prefix, + tcdFDs = [], + tcdSigs = fmap (mkL' (DifferentLine 1 2)) sigs, + tcdMeths = emptyBag, + tcdATs = [], + tcdATDefs = [], + tcdDocs = [] + } + where + annos = + [ AddEpAnn AnnClass (mkEpaDelta (-1)), + AddEpAnn AnnWhere (mkEpaDelta 0) + ] + annCtxt + | null ctxt = AnnContext Nothing [] [] + | otherwise = + AnnContext + { ac_darrow = Just (NormalSyntax, mkEpaDelta 0), + ac_open = [mkEpaDelta (-1)], + ac_close = [mkEpaDelta (-1)] + } + mkInstance :: -- | Context HsContext GhcPs -> @@ -806,6 +916,18 @@ instD = InstD noExtField . ClsInstD noExtField mkPVar :: String -> Pat GhcPs mkPVar name = VarPat noExtField (mkLIdP (-1) name) +mkPVarSig :: String -> HsType GhcPs -> Pat GhcPs +mkPVarSig name typ = + SigPat + (mkRelEpAnn (-1) annos) + (mkL (-1) (mkPVar name)) + psig + where + annos = + [ AddEpAnn AnnDcolon (mkEpaDelta 0) + ] + psig = HsPS (mkRelEpAnn (-1) NoEpAnns) (mkL 0 typ) + pApp :: String -> [Pat GhcPs] -> Pat GhcPs pApp name pats = ConPat @@ -875,6 +997,13 @@ inapp x o y = lo = mkL (-1) o ly = mkL (-1) y +letE :: HsLocalBinds GhcPs -> HsExpr GhcPs -> HsExpr GhcPs +letE bnds expr = + HsLet (mkRelEpAnn' (DifferentLine 1 2) NoEpAnns) tokLet bnds tokIn (mkL 0 expr) + where + tokLet = L (tokLoc (-1)) HsTok + tokIn = L (tokLoc 1) HsTok + listE :: [HsExpr GhcPs] -> HsExpr GhcPs listE itms = case itms of @@ -916,6 +1045,16 @@ strE str = HsLit ann1 (HsString ann2 (fromString str)) ann1 = mkRelEpAnn (-1) NoEpAnns ann2 = SourceText str' +valBinds :: [HsBind GhcPs] -> HsValBinds GhcPs +valBinds bnds = + ValBinds NoAnnSortKey (listToBag lbnds) [] + where + lbnds = paragraphLines' (SameLine 2) bnds + +toLocalBinds :: HsValBinds GhcPs -> HsLocalBinds GhcPs +toLocalBinds = + HsValBinds (mkRelEpAnn' (DifferentLine 1 2) noAnnList) + -- -- Statements -- @@ -926,6 +1065,15 @@ mkBodyStmt expr = where body = mkL (-1) expr +pbind :: Pat GhcPs -> HsExpr GhcPs -> HsLocalBinds GhcPs -> HsBind GhcPs +pbind pat expr bnds = + PatBind (mkRelEpAnn (-1) []) (mkL (-1) pat) grhss + where + grhss = GRHSs emptyComments [lgrhs] bnds + lgrhs = L (mkRelSrcSpanAnn (-1) NoEpAnns) grhs + grhs = GRHS (mkRelEpAnn (-1) ann) [] (mkL 0 expr) + ann = GrhsAnn Nothing (AddEpAnn AnnEqual (mkEpaDelta 0)) + -- -- utilities -- @@ -1065,21 +1213,9 @@ lit = Lit () mkIVar :: String -> ImportSpec () mkIVar = IVar () . Ident () -mkPVarSig :: String -> Type () -> Pat () -mkPVarSig n typ = PatTypeSig () (mkPVar n) typ - -pbind :: Pat () -> Exp () -> Maybe (Binds ()) -> Decl () -pbind pat e = PatBind () pat (UnGuardedRhs () e) - pbind_ :: Pat () -> Exp () -> Decl () pbind_ p e = pbind p e Nothing -mkTBind :: String -> TyVarBind () -mkTBind = UnkindedVar () . Ident () - -mkClass :: Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl () -mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds) [] (Just cdecls) - dhead :: String -> DeclHead () dhead n = DHead () (Ident () n) @@ -1098,19 +1234,9 @@ mkImportExp m lst = where islist = ImportSpecList () False (map mkIVar lst) -mkImportSrc :: String -> ImportDecl () -mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing - dot :: Exp () -> Exp () -> Exp () x `dot` y = x `app` mkVar "." `app` y -tyForall :: - Maybe [TyVarBind ()] -> - Maybe (Context ()) -> - Type () -> - Type () -tyForall = TyForall () - tyForeignPtr :: Type () tyForeignPtr = tycon "ForeignPtr" @@ -1157,9 +1283,6 @@ generator = Generator () qualifier :: Exp () -> Stmt () qualifier = Qualifier () -clsDecl :: Decl () -> ClassDecl () -clsDecl = ClsDecl () - unkindedVar :: Name () -> TyVarBind () unkindedVar = UnkindedVar () From 612ec492dac0a2a2087469440f12a6884d2a6e48 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Fri, 11 Aug 2023 16:21:37 -0700 Subject: [PATCH 08/19] Move top-level template codegen to HsTopLevel (#218) Moved top-level template codegen to HsTopLevel, TMF codegen to HsImplementation and split HsTemplate to HsTH and HsTemplate. * move top-level template codegen to HsTopLevel * move template member functions to HsImplementation * separate out HsTemplate to HsTemplate and HsTH. --- fficxx/fficxx.cabal | 1 + .../FFICXX/Generate/Code/HsImplementation.hs | 138 +++- fficxx/src/FFICXX/Generate/Code/HsTH.hs | 322 +++++++++ fficxx/src/FFICXX/Generate/Code/HsTemplate.hs | 633 +----------------- fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs | 274 +++++++- fficxx/src/FFICXX/Generate/ContentMaker.hs | 19 +- 6 files changed, 748 insertions(+), 639 deletions(-) create mode 100644 fficxx/src/FFICXX/Generate/Code/HsTH.hs diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 958b2132..581870c4 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -62,6 +62,7 @@ Library FFICXX.Generate.Code.HsInterface FFICXX.Generate.Code.HsProxy FFICXX.Generate.Code.HsRawType + FFICXX.Generate.Code.HsTH FFICXX.Generate.Code.HsTemplate FFICXX.Generate.Code.HsTopLevel FFICXX.Generate.Code.Cabal diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs index 7d53535c..1ed32697 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs @@ -13,20 +13,29 @@ module FFICXX.Generate.Code.HsImplementation genHsFrontInstNonVirtual, genHsFrontInstStatic, genHsFrontInstVariables, + + -- * template member functions + genTemplateMemberFunctions, + genTMFExp, + genTMFInstance, ) where import Control.Monad.Reader (Reader) +import qualified Data.List as L (foldr1) import FFICXX.Generate.Code.Primitive ( accessorSignature, cxx2HsType, functionSignature', + functionSignatureTMF, hsFuncXformer, ) import FFICXX.Generate.Name ( accessorName, aliasedFuncName, hsFuncName, + hsTemplateMemberFunctionName, + hsTemplateMemberFunctionNameTH, hscAccessorName, hscFuncName, subModuleName, @@ -36,6 +45,7 @@ import FFICXX.Generate.Type.Annotate (AnnotateMap) import FFICXX.Generate.Type.Class ( Accessor (..), Class (..), + TemplateMemberFunction (..), Types (..), isAbstractClass, isNewFunc, @@ -43,7 +53,10 @@ import FFICXX.Generate.Type.Class staticFuncs, virtualFuncs, ) -import FFICXX.Generate.Type.Module (ClassModule (..)) +import FFICXX.Generate.Type.Module + ( ClassImportHeader (..), + ClassModule (..), + ) import FFICXX.Generate.Util.GHCExactPrint ( app, cxEmpty, @@ -54,7 +67,12 @@ import FFICXX.Generate.Util.GHCExactPrint mkInstance, mkVar, ) +import qualified FFICXX.Generate.Util.HaskellSrcExts as O hiding (app, doE, listE, qualStmt, strE) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import qualified FFICXX.Runtime.CodeGen.Cxx as R import GHC.Hs (GhcPs) +import qualified Language.Haskell.Exts.Build as O hiding (op) +import qualified Language.Haskell.Exts.Syntax as O import Language.Haskell.Syntax (HsDecl, ImportDecl) -- @@ -117,3 +135,121 @@ genHsFrontInstVariables c = (mkVar (hscAccessorName c v accessor)) in mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing + +-- +-- Template Member Function +-- + +genTemplateMemberFunctions :: ClassImportHeader -> [O.Decl ()] +genTemplateMemberFunctions cih = + let c = cihClass cih + in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c) + +-- TODO: combine this with genTmplInstance +genTMFExp :: Class -> TemplateMemberFunction -> [O.Decl ()] +genTMFExp c f = O.mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + where + nh = hsTemplateMemberFunctionNameTH c f + v = O.mkVar + p = O.mkPVar + itps = zip ([1 ..] :: [Int]) (tmf_params f) + tvars = map (\(i, _) -> "typ" ++ show i) itps + nparams = length itps + tparams = if nparams == 1 then O.tycon "Type" else O.tyTupleBoxed (replicate nparams (O.tycon "Type")) + sig = foldr1 O.tyfun [tparams, O.tycon "String", O.tyapp (O.tycon "Q") (O.tycon "Exp")] + tvars_p = if nparams == 1 then map p tvars else [O.pTuple (map p tvars)] + lit' = O.strE (hsTemplateMemberFunctionName c f <> "_") + lam = O.lamE [p "n"] (lit' `O.app` v "<>" `O.app` v "n") + rhs = + O.app (v "mkTFunc") $ + let typs = if nparams == 1 then map v tvars else [O.tuple (map v tvars)] + in O.tuple (typs ++ [v "suffix", lam, v "tyf"]) + sig' = functionSignatureTMF c f + tassgns = map (\(i, tp) -> O.pbind_ (p tp) (v "pure" `O.app` (v ("typ" ++ show i)))) itps + bstmts = + O.binds + [ O.mkBind1 + "tyf" + [O.mkPVar "n"] + ( O.letE + tassgns + (O.bracketExp (O.typeBracket sig')) + ) + Nothing + ] + +genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [O.Decl ()] +genTMFInstance cih f = + O.mkFun + fname + sig + [p "isCprim", O.pTuple [p "qtyp", p "param"]] + rhs + Nothing + where + c = cihClass cih + fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f + p = O.mkPVar + v = O.mkVar + sig = + O.tycon "IsCPrimitive" + `O.tyfun` O.tyTupleBoxed [O.tycon "Q" `O.tyapp` O.tycon "Type", O.tycon "TemplateParamInfo"] + `O.tyfun` (O.tycon "Q" `O.tyapp` O.tylist (O.tycon "Dec")) + rhs = O.doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, O.letStmt lststmt, O.qualStmt retstmt] + suffixstmt = O.letStmt [O.pbind_ (p "suffix") (v "tpinfoSuffix" `O.app` v "param")] + qtypstmt = O.generator (p "typ") (v "qtyp") + genstmt = + O.generator + (p "f1") + ( v "mkMember" + `O.app` ( O.strE (hsTemplateMemberFunctionName c f <> "_") + `O.app` v "<>" + `O.app` v "suffix" + ) + `O.app` v (hsTemplateMemberFunctionNameTH c f) + `O.app` v "typ" + `O.app` v "suffix" + ) + lststmt = [O.pbind_ (p "lst") (O.listE ([v "f1"]))] + retstmt = v "pure" `O.app` v "lst" + -- TODO: refactor out the following code. + foreignSrcStmt = + O.qualifier $ + (v "addModFinalizer") + `O.app` ( v "addForeignSource" + `O.app` O.con "LangCxx" + `O.app` ( L.foldr1 + (\x y -> O.inapp x (O.op "++") y) + [ includeStatic, + includeDynamic, + namespaceStr, + O.strE (hsTemplateMemberFunctionName c f), + O.strE "(", + v "suffix", + O.strE ")\n" + ] + ) + ) + where + includeStatic = + O.strE $ + concatMap ((<> "\n") . R.renderCMacro . R.Include) $ + [HdrName "MacroPatternMatch.h", cihSelfHeader cih] + <> cihIncludedHPkgHeadersInCPP cih + <> cihIncludedCPkgHeaders cih + includeDynamic = + O.letE + [ O.pbind_ (p "headers") (v "tpinfoCxxHeaders" `O.app` v "param"), + O.pbind_ + (O.pApp (O.name "f") [p "x"]) + (v "renderCMacro" `O.app` (O.con "Include" `O.app` v "x")) + ] + (v "concatMap" `O.app` v "f" `O.app` v "headers") + namespaceStr = + O.letE + [ O.pbind_ (p "nss") (v "tpinfoCxxNamespaces" `O.app` v "param"), + O.pbind_ + (O.pApp (O.name "f") [p "x"]) + (v "renderCStmt" `O.app` (O.con "UsingNamespace" `O.app` v "x")) + ] + (v "concatMap" `O.app` v "f" `O.app` v "nss") diff --git a/fficxx/src/FFICXX/Generate/Code/HsTH.hs b/fficxx/src/FFICXX/Generate/Code/HsTH.hs new file mode 100644 index 00000000..fa30bf56 --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Code/HsTH.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsTH + ( genImportInTH, + genTmplImplementation, + genTmplInstance, + ) +where + +import qualified Data.List as L (foldr1) +import FFICXX.Generate.Code.Cpp + ( genTmplClassCpp, + genTmplFunCpp, + genTmplVarCpp, + ) +import FFICXX.Generate.Code.Primitive + ( functionSignatureTT, + tmplAccessorToTFun, + ) +import FFICXX.Generate.Dependency (calculateDependency) +import FFICXX.Generate.Name + ( ffiTmplFuncName, + hsTmplFuncName, + hsTmplFuncNameTH, + subModuleName, + tmplAccessorName, + typeclassNameT, + ) +import FFICXX.Generate.Type.Class + ( Accessor (Getter, Setter), + Arg (..), + TemplateClass (..), + TemplateFunction (..), + Types (Void), + Variable (..), + ) +import FFICXX.Generate.Type.Module + ( TemplateClassImportHeader (..), + TemplateClassSubmoduleType (..), + ) +import FFICXX.Generate.Util.HaskellSrcExts + ( bracketExp, + con, + generator, + inapp, + match, + mkBind1, + mkFun, + mkImport, + mkPVar, + mkTBind, + mkVar, + op, + pbind_, + qualifier, + tyTupleBoxed, + tyapp, + tycon, + tyfun, + tylist, + typeBracket, + ) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import Language.Haskell.Exts.Build + ( app, + binds, + caseE, + doE, + lamE, + letE, + letStmt, + listE, + name, + pApp, + pTuple, + paren, + qualStmt, + strE, + tuple, + wildcard, + ) +import Language.Haskell.Exts.Syntax + ( Decl, + ImportDecl, + ) + +genImportInTH :: TemplateClass -> [ImportDecl ()] +genImportInTH t0 = + fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0) + +-- +-- implementation +-- + +genTmplImplementation :: TemplateClass -> [Decl ()] +genTmplImplementation t = + concatMap gen (tclass_funcs t) ++ concatMap genV (tclass_vars t) + where + v = mkVar + p = mkPVar + itps = zip ([1 ..] :: [Int]) (tclass_params t) + tvars = map (\(i, _) -> "typ" ++ show i) itps + nparams = length itps + tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) + sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] + tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] + prefix = tclass_name t + gen f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + where + nh = hsTmplFuncNameTH t f + nc = ffiTmplFuncName f + lit' = strE (prefix <> "_" <> nc) + lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + rhs = + app (v "mkTFunc") $ + let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] + in tuple (typs ++ [v "suffix", lam, v "tyf"]) + sig' = functionSignatureTT t f + tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps + bstmts = + binds + [ mkBind1 + "tyf" + [wildcard] + ( letE + tassgns + (bracketExp (typeBracket sig')) + ) + Nothing + ] + genV vf = + let f_g = tmplAccessorToTFun vf Getter + f_s = tmplAccessorToTFun vf Setter + in gen f_g ++ gen f_s + +genTmplInstance :: + TemplateClassImportHeader -> + [Decl ()] +genTmplInstance tcih = + mkFun + fname + sig + (p "isCprim" : zipWith (\x y -> pTuple [p x, p y]) qtvars pvars) + rhs + Nothing + where + t = tcihTClass tcih + fs = tclass_funcs t + vfs = tclass_vars t + tname = tclass_name t + fname = "gen" <> tname <> "InstanceFor" + p = mkPVar + v = mkVar + itps = zip ([1 ..] :: [Int]) (tclass_params t) + tvars = map (\(i, _) -> "typ" ++ show i) itps + qtvars = map (\(i, _) -> "qtyp" ++ show i) itps + pvars = map (\(i, _) -> "param" ++ show i) itps + nparams = length itps + typs_v = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars) + params_l = listE (map v pvars) + sig = + foldr1 tyfun $ + [tycon "IsCPrimitive"] + ++ replicate + nparams + (tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) + ++ [tycon "Q" `tyapp` tylist (tycon "Dec")] + nfs = zip ([1 ..] :: [Int]) fs + nvfs = zip ([1 ..] :: [Int]) vfs + -------------------------- + -- final RHS expression -- + -------------------------- + rhs = + doE + ( [paramsstmt, suffixstmt] + <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), + letStmt + [ pbind_ + (p "callmod") + (v "dot2_" `app` v "callmod_") + ] + ] + <> map genqtypstmt (zip tvars qtvars) + <> map genstmt nfs + <> concatMap genvarstmt nvfs + <> [foreignSrcStmt, letStmt lststmt, qualStmt retstmt] + ) + -------------------------- + paramsstmt = + letStmt + [ pbind_ + (p "params") + (v "map" `app` (v "tpinfoSuffix") `app` params_l) + ] + suffixstmt = + letStmt + [ pbind_ + (p "suffix") + ( v "concatMap" + `app` (lamE [p "x"] (inapp (strE "_") (op "++") (v "tpinfoSuffix" `app` v "x"))) + `app` params_l + ) + ] + genqtypstmt (tvar, qtvar) = generator (p tvar) (v qtvar) + gen prefix nm f n = + generator + (p (prefix <> show n)) + ( v nm + `app` strE (hsTmplFuncName t f) + `app` v (hsTmplFuncNameTH t f) + `app` typs_v + `app` v "suffix" + ) + genstmt (n, f@TFun {}) = gen "f" "mkMember" f n + genstmt (n, f@TFunNew {}) = gen "f" "mkNew" f n + genstmt (n, f@TFunDelete) = gen "f" "mkDelete" f n + genstmt (n, f@TFunOp {}) = gen "f" "mkMember" f n + genvarstmt (n, vf) = + let Variable (Arg {..}) = vf + f_g = + TFun + { tfun_ret = arg_type, + tfun_name = tmplAccessorName vf Getter, + tfun_oname = tmplAccessorName vf Getter, + tfun_args = [] + } + f_s = + TFun + { tfun_ret = Void, + tfun_name = tmplAccessorName vf Setter, + tfun_oname = tmplAccessorName vf Setter, + tfun_args = [Arg arg_type "value"] + } + in [ gen "vf" "mkMember" f_g (2 * n - 1), + gen "vf" "mkMember" f_s (2 * n) + ] + lststmt = + let mkElems prefix xs = map (v . (\n -> prefix <> show n) . fst) xs + in [ pbind_ + (p "lst") + ( listE + ( mkElems "f" nfs + <> mkElems "vf" (concatMap (\(n, vf) -> [(2 * n - 1, vf), (2 * n, vf)]) nvfs) + ) + ) + ] + -- TODO: refactor out the following code. + foreignSrcStmt = + qualifier $ + (v "addModFinalizer") + `app` ( v "addForeignSource" + `app` con "LangCxx" + `app` ( L.foldr1 + (\x y -> inapp x (op "++") y) + [ includeStatic, + includeDynamic, + namespaceStr, + strE (tname <> "_instance"), + paren $ + caseE + (v "isCprim") + [ match (p "CPrim") (strE "_s"), + match (p "NonCPrim") (strE "") + ], + strE "(", + v "intercalate" + `app` strE ", " + `app` paren (inapp (v "callmod") (op ":") (v "params")), + strE ")\n" + ] + ) + ) + where + -- temporary + body = + map R.renderCMacro $ + map R.Include (tcihCxxHeaders tcih) + ++ map (genTmplFunCpp NonCPrim t) fs + ++ map (genTmplFunCpp CPrim t) fs + ++ concatMap (genTmplVarCpp NonCPrim t) vfs + ++ concatMap (genTmplVarCpp CPrim t) vfs + ++ [ genTmplClassCpp NonCPrim t (fs, vfs), + genTmplClassCpp CPrim t (fs, vfs) + ] + includeStatic = + strE $ + concatMap + (<> "\n") + ( [R.renderCMacro (R.Include (HdrName "MacroPatternMatch.h"))] + ++ body + ) + cxxHeaders = v "concatMap" `app` (v "tpinfoCxxHeaders") `app` params_l + cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l + includeDynamic = + letE + [ pbind_ (p "headers") cxxHeaders, + pbind_ + (pApp (name "f") [p "x"]) + (v "renderCMacro" `app` (con "Include" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "headers") + namespaceStr = + letE + [ pbind_ (p "nss") cxxNamespaces, + pbind_ + (pApp (name "f") [p "x"]) + (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "nss") + retstmt = + v "pure" + `app` listE + [ v "mkInstance" + `app` listE [] + `app` foldl1 + (\f x -> con "AppT" `app` f `app` x) + (v "con" `app` strE (typeclassNameT t) : map v tvars) + `app` (v "lst") + ] diff --git a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs index 386ac508..7529dfee 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs @@ -1,69 +1,41 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -module FFICXX.Generate.Code.HsTemplate where - -import qualified Data.List as L (foldr1) -import FFICXX.Generate.Code.Cpp - ( genTLTmplFunCpp, - genTmplClassCpp, - genTmplFunCpp, - genTmplVarCpp, +module FFICXX.Generate.Code.HsTemplate + ( genImportInTemplate, + genTmplInterface, ) +where + import FFICXX.Generate.Code.HsCast (castBody_) import FFICXX.Generate.Code.Primitive - ( convertCpp2HS, - convertCpp2HS4Tmpl, - functionSignatureT, - functionSignatureTMF, - functionSignatureTT, + ( functionSignatureT, tmplAccessorToTFun, ) import FFICXX.Generate.Dependency (calculateDependency) import FFICXX.Generate.Name - ( ffiTmplFuncName, - hsTemplateClassName, - hsTemplateMemberFunctionName, - hsTemplateMemberFunctionNameTH, + ( hsTemplateClassName, hsTmplFuncName, - hsTmplFuncNameTH, subModuleName, - tmplAccessorName, typeclassNameT, ) import FFICXX.Generate.Type.Class ( Accessor (Getter, Setter), - Arg (..), - Class (..), - TLTemplate (..), TemplateClass (..), - TemplateFunction (..), - TemplateMemberFunction (..), - Types (Void), - Variable (..), ) import FFICXX.Generate.Type.Module - ( ClassImportHeader (..), - TemplateClassImportHeader (..), - TemplateClassSubmoduleType (..), - TopLevelImportHeader (..), + ( TemplateClassSubmoduleType (..), ) -import FFICXX.Generate.Util (firstUpper) import FFICXX.Generate.Util.HaskellSrcExts - ( bracketExp, - clsDecl, + ( clsDecl, con, conDecl, cxEmpty, - generator, - inapp, insDecl, insType, - match, mkBind1, mkClass, mkData, - mkFun, mkFunSig, mkImport, mkInstance, @@ -72,168 +44,20 @@ import FFICXX.Generate.Util.HaskellSrcExts mkTBind, mkTVar, mkVar, - op, - parenSplice, - pbind_, qualConDecl, - qualifier, tyPtr, - tySplice, - tyTupleBoxed, tyapp, tycon, - tyfun, - tylist, - typeBracket, ) -import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) -import qualified FFICXX.Runtime.CodeGen.Cxx as R -import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) import Language.Haskell.Exts.Build - ( app, - binds, - caseE, - doE, - lamE, - letE, - letStmt, - listE, - name, + ( name, pApp, - pTuple, - paren, - qualStmt, - strE, - tuple, - wildcard, ) import Language.Haskell.Exts.Syntax ( Decl, ImportDecl, ) ------------------------------- --- Template member function -- ------------------------------- - -genTemplateMemberFunctions :: ClassImportHeader -> [Decl ()] -genTemplateMemberFunctions cih = - let c = cihClass cih - in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c) - --- TODO: combine this with genTmplInstance -genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()] -genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) - where - nh = hsTemplateMemberFunctionNameTH c f - v = mkVar - p = mkPVar - itps = zip ([1 ..] :: [Int]) (tmf_params f) - tvars = map (\(i, _) -> "typ" ++ show i) itps - nparams = length itps - tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) - sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] - tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] - lit' = strE (hsTemplateMemberFunctionName c f <> "_") - lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") - rhs = - app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] - in tuple (typs ++ [v "suffix", lam, v "tyf"]) - sig' = functionSignatureTMF c f - tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps - bstmts = - binds - [ mkBind1 - "tyf" - [mkPVar "n"] - ( letE - tassgns - (bracketExp (typeBracket sig')) - ) - Nothing - ] - -genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [Decl ()] -genTMFInstance cih f = - mkFun - fname - sig - [p "isCprim", pTuple [p "qtyp", p "param"]] - rhs - Nothing - where - c = cihClass cih - fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f - p = mkPVar - v = mkVar - sig = - tycon "IsCPrimitive" - `tyfun` tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"] - `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec")) - rhs = doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, letStmt lststmt, qualStmt retstmt] - suffixstmt = letStmt [pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param")] - qtypstmt = generator (p "typ") (v "qtyp") - genstmt = - generator - (p "f1") - ( v "mkMember" - `app` ( strE (hsTemplateMemberFunctionName c f <> "_") - `app` v "<>" - `app` v "suffix" - ) - `app` v (hsTemplateMemberFunctionNameTH c f) - `app` v "typ" - `app` v "suffix" - ) - lststmt = [pbind_ (p "lst") (listE ([v "f1"]))] - retstmt = v "pure" `app` v "lst" - -- TODO: refactor out the following code. - foreignSrcStmt = - qualifier $ - (v "addModFinalizer") - `app` ( v "addForeignSource" - `app` con "LangCxx" - `app` ( L.foldr1 - (\x y -> inapp x (op "++") y) - [ includeStatic, - includeDynamic, - namespaceStr, - strE (hsTemplateMemberFunctionName c f), - strE "(", - v "suffix", - strE ")\n" - ] - ) - ) - where - includeStatic = - strE $ - concatMap ((<> "\n") . R.renderCMacro . R.Include) $ - [HdrName "MacroPatternMatch.h", cihSelfHeader cih] - <> cihIncludedHPkgHeadersInCPP cih - <> cihIncludedCPkgHeaders cih - includeDynamic = - letE - [ pbind_ (p "headers") (v "tpinfoCxxHeaders" `app` v "param"), - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCMacro" `app` (con "Include" `app` v "x")) - ] - (v "concatMap" `app` v "f" `app` v "headers") - namespaceStr = - letE - [ pbind_ (p "nss") (v "tpinfoCxxNamespaces" `app` v "param"), - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) - ] - (v "concatMap" `app` v "f" `app` v "nss") - --------------------- --- Template Class -- --------------------- - genImportInTemplate :: TemplateClass -> [ImportDecl ()] genImportInTemplate t0 = fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTemplate, t0) @@ -268,440 +92,3 @@ genTmplInterface t = insDecl (mkBind1 "get_fptr" [pApp (name hname) [mkPVar "ptr"]] (mkVar "ptr") Nothing), insDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing) ] - -genImportInTH :: TemplateClass -> [ImportDecl ()] -genImportInTH t0 = - fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0) - -genTmplImplementation :: TemplateClass -> [Decl ()] -genTmplImplementation t = - concatMap gen (tclass_funcs t) ++ concatMap genV (tclass_vars t) - where - v = mkVar - p = mkPVar - itps = zip ([1 ..] :: [Int]) (tclass_params t) - tvars = map (\(i, _) -> "typ" ++ show i) itps - nparams = length itps - tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) - sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] - tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] - prefix = tclass_name t - gen f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) - where - nh = hsTmplFuncNameTH t f - nc = ffiTmplFuncName f - lit' = strE (prefix <> "_" <> nc) - lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") - rhs = - app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] - in tuple (typs ++ [v "suffix", lam, v "tyf"]) - sig' = functionSignatureTT t f - tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps - bstmts = - binds - [ mkBind1 - "tyf" - [wildcard] - ( letE - tassgns - (bracketExp (typeBracket sig')) - ) - Nothing - ] - genV vf = - let f_g = tmplAccessorToTFun vf Getter - f_s = tmplAccessorToTFun vf Setter - in gen f_g ++ gen f_s - -genTmplInstance :: - TemplateClassImportHeader -> - [Decl ()] -genTmplInstance tcih = - mkFun - fname - sig - (p "isCprim" : zipWith (\x y -> pTuple [p x, p y]) qtvars pvars) - rhs - Nothing - where - t = tcihTClass tcih - fs = tclass_funcs t - vfs = tclass_vars t - tname = tclass_name t - fname = "gen" <> tname <> "InstanceFor" - p = mkPVar - v = mkVar - itps = zip ([1 ..] :: [Int]) (tclass_params t) - tvars = map (\(i, _) -> "typ" ++ show i) itps - qtvars = map (\(i, _) -> "qtyp" ++ show i) itps - pvars = map (\(i, _) -> "param" ++ show i) itps - nparams = length itps - typs_v = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars) - params_l = listE (map v pvars) - sig = - foldr1 tyfun $ - [tycon "IsCPrimitive"] - ++ replicate - nparams - (tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) - ++ [tycon "Q" `tyapp` tylist (tycon "Dec")] - nfs = zip ([1 ..] :: [Int]) fs - nvfs = zip ([1 ..] :: [Int]) vfs - -------------------------- - -- final RHS expression -- - -------------------------- - rhs = - doE - ( [paramsstmt, suffixstmt] - <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), - letStmt - [ pbind_ - (p "callmod") - (v "dot2_" `app` v "callmod_") - ] - ] - <> map genqtypstmt (zip tvars qtvars) - <> map genstmt nfs - <> concatMap genvarstmt nvfs - <> [foreignSrcStmt, letStmt lststmt, qualStmt retstmt] - ) - -------------------------- - paramsstmt = - letStmt - [ pbind_ - (p "params") - (v "map" `app` (v "tpinfoSuffix") `app` params_l) - ] - suffixstmt = - letStmt - [ pbind_ - (p "suffix") - ( v "concatMap" - `app` (lamE [p "x"] (inapp (strE "_") (op "++") (v "tpinfoSuffix" `app` v "x"))) - `app` params_l - ) - ] - genqtypstmt (tvar, qtvar) = generator (p tvar) (v qtvar) - gen prefix nm f n = - generator - (p (prefix <> show n)) - ( v nm - `app` strE (hsTmplFuncName t f) - `app` v (hsTmplFuncNameTH t f) - `app` typs_v - `app` v "suffix" - ) - genstmt (n, f@TFun {}) = gen "f" "mkMember" f n - genstmt (n, f@TFunNew {}) = gen "f" "mkNew" f n - genstmt (n, f@TFunDelete) = gen "f" "mkDelete" f n - genstmt (n, f@TFunOp {}) = gen "f" "mkMember" f n - genvarstmt (n, vf) = - let Variable (Arg {..}) = vf - f_g = - TFun - { tfun_ret = arg_type, - tfun_name = tmplAccessorName vf Getter, - tfun_oname = tmplAccessorName vf Getter, - tfun_args = [] - } - f_s = - TFun - { tfun_ret = Void, - tfun_name = tmplAccessorName vf Setter, - tfun_oname = tmplAccessorName vf Setter, - tfun_args = [Arg arg_type "value"] - } - in [ gen "vf" "mkMember" f_g (2 * n - 1), - gen "vf" "mkMember" f_s (2 * n) - ] - lststmt = - let mkElems prefix xs = map (v . (\n -> prefix <> show n) . fst) xs - in [ pbind_ - (p "lst") - ( listE - ( mkElems "f" nfs - <> mkElems "vf" (concatMap (\(n, vf) -> [(2 * n - 1, vf), (2 * n, vf)]) nvfs) - ) - ) - ] - -- TODO: refactor out the following code. - foreignSrcStmt = - qualifier $ - (v "addModFinalizer") - `app` ( v "addForeignSource" - `app` con "LangCxx" - `app` ( L.foldr1 - (\x y -> inapp x (op "++") y) - [ includeStatic, - includeDynamic, - namespaceStr, - strE (tname <> "_instance"), - paren $ - caseE - (v "isCprim") - [ match (p "CPrim") (strE "_s"), - match (p "NonCPrim") (strE "") - ], - strE "(", - v "intercalate" - `app` strE ", " - `app` paren (inapp (v "callmod") (op ":") (v "params")), - strE ")\n" - ] - ) - ) - where - -- temporary - body = - map R.renderCMacro $ - map R.Include (tcihCxxHeaders tcih) - ++ map (genTmplFunCpp NonCPrim t) fs - ++ map (genTmplFunCpp CPrim t) fs - ++ concatMap (genTmplVarCpp NonCPrim t) vfs - ++ concatMap (genTmplVarCpp CPrim t) vfs - ++ [ genTmplClassCpp NonCPrim t (fs, vfs), - genTmplClassCpp CPrim t (fs, vfs) - ] - includeStatic = - strE $ - concatMap - (<> "\n") - ( [R.renderCMacro (R.Include (HdrName "MacroPatternMatch.h"))] - ++ body - ) - cxxHeaders = v "concatMap" `app` (v "tpinfoCxxHeaders") `app` params_l - cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l - includeDynamic = - letE - [ pbind_ (p "headers") cxxHeaders, - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCMacro" `app` (con "Include" `app` v "x")) - ] - (v "concatMap" `app` v "f" `app` v "headers") - namespaceStr = - letE - [ pbind_ (p "nss") cxxNamespaces, - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) - ] - (v "concatMap" `app` v "f" `app` v "nss") - retstmt = - v "pure" - `app` listE - [ v "mkInstance" - `app` listE [] - `app` foldl1 - (\f x -> con "AppT" `app` f `app` x) - (v "con" `app` strE (typeclassNameT t) : map v tvars) - `app` (v "lst") - ] - ---------------- --- top-level -- ---------------- - -genTLTemplateInterface :: TLTemplate -> [Decl ()] -genTLTemplateInterface t = - [ mkClass cxEmpty (firstUpper (topleveltfunc_name t)) (map mkTBind tps) methods - ] - where - tps = topleveltfunc_params t - ctyp = convertCpp2HS Nothing (topleveltfunc_ret t) - lst = map (convertCpp2HS Nothing . arg_type) (topleveltfunc_args t) - sigdecl = mkFunSig (topleveltfunc_name t) $ foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) - methods = [clsDecl sigdecl] - -genTLTemplateImplementation :: TLTemplate -> [Decl ()] -genTLTemplateImplementation t = - mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) - where - v = mkVar - p = mkPVar - itps = zip ([1 ..] :: [Int]) (topleveltfunc_params t) - tvars = map (\(i, _) -> "typ" ++ show i) itps - nparams = length itps - tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) - sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] - tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] - prefix = "TL" - nh = "t_" <> topleveltfunc_name t - nc = topleveltfunc_name t - lit' = strE (prefix <> "_" <> nc) - lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") - rhs = - app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] - in tuple (typs ++ [v "suffix", lam, v "tyf"]) - sig' = - let e = error "genTLTemplateImplementation" - spls = map (tySplice . parenSplice . mkVar) $ topleveltfunc_params t - ctyp = convertCpp2HS4Tmpl e Nothing spls (topleveltfunc_ret t) - lst = map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (topleveltfunc_args t) - in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) - tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps - bstmts = - binds - [ mkBind1 - "tyf" - [wildcard] - ( letE - tassgns - (bracketExp (typeBracket sig')) - ) - Nothing - ] - -genTLTemplateInstance :: - TopLevelImportHeader -> - TLTemplate -> - [Decl ()] -genTLTemplateInstance tih t = - mkFun - fname - sig - (p "isCprim" : zipWith (\x y -> pTuple [p x, p y]) qtvars pvars) - rhs - Nothing - where - p = mkPVar - v = mkVar - tcname = firstUpper (topleveltfunc_name t) - fname = "gen" <> tcname <> "InstanceFor" - itps = zip ([1 ..] :: [Int]) (topleveltfunc_params t) - tvars = map (\(i, _) -> "typ" ++ show i) itps - qtvars = map (\(i, _) -> "qtyp" ++ show i) itps - pvars = map (\(i, _) -> "param" ++ show i) itps - nparams = length itps - typs_v = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars) - params_l = listE (map v pvars) - sig = - foldr1 tyfun $ - [tycon "IsCPrimitive"] - ++ replicate - nparams - (tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) - ++ [tycon "Q" `tyapp` tylist (tycon "Dec")] - -- nvfs = zip ([1..] :: [Int]) vfs - - -------------------------- - -- final RHS expression -- - -------------------------- - rhs = - doE - ( [paramsstmt, suffixstmt] - <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), - letStmt - [ pbind_ - (p "callmod") - (v "dot2_" `app` v "callmod_") - ] - ] - <> map genqtypstmt (zip tvars qtvars) - <> [genstmt "f" (1 :: Int)] - <> [ foreignSrcStmt, - letStmt lststmt, - qualStmt retstmt - ] - ) - -------------------------- - paramsstmt = - letStmt - [ pbind_ - (p "params") - (v "map" `app` (v "tpinfoSuffix") `app` params_l) - ] - suffixstmt = - letStmt - [ pbind_ - (p "suffix") - ( v "concatMap" - `app` (lamE [p "x"] (inapp (strE "_") (op "++") (v "tpinfoSuffix" `app` v "x"))) - `app` params_l - ) - ] - genqtypstmt (tvar, qtvar) = generator (p tvar) (v qtvar) - genstmt prefix n = - generator - (p (prefix <> show n)) - ( v "mkFunc" - `app` strE (topleveltfunc_name t) - `app` v ("t_" <> topleveltfunc_name t) - `app` typs_v - `app` v "suffix" - ) - lststmt = [pbind_ (p "lst") (listE [v "f1"])] - -- TODO: refactor out the following code. - foreignSrcStmt = - qualifier $ - (v "addModFinalizer") - `app` ( v "addForeignSource" - `app` con "LangCxx" - `app` ( L.foldr1 - (\x y -> inapp x (op "++") y) - [ includeStatic, - {- , includeDynamic - , namespaceStr -} - strE (tcname <> "_instance"), - paren $ - caseE - (v "isCprim") - [ match (p "CPrim") (strE "_s"), - match (p "NonCPrim") (strE "") - ], - strE "(", - v "intercalate" - `app` strE ", " - `app` paren (inapp (v "callmod") (op ":") (v "params")), - strE ")\n" - ] - ) - ) - where - -- temporary - includeStatic = - strE $ - concatMap - (<> "\n") - ( [R.renderCMacro (R.Include (HdrName "MacroPatternMatch.h"))] - ++ map - R.renderCMacro - ( map R.Include (tihExtraHeadersInCPP tih) - ++ [genTLTmplFunCpp CPrim t, genTLTmplFunCpp NonCPrim t] - ) - ) - {- - cxxHeaders = v "concatMap" `app` (v "tpinfoCxxHeaders") `app` params_l - cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l - - includeDynamic = - letE - [ pbind_ (p "headers") cxxHeaders, - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCMacro" `app` (con "Include" `app` v "x")) - ] - (v "concatMap" `app` v "f" `app` v "headers") - - namespaceStr = - letE - [ pbind_ (p "nss") cxxNamespaces, - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) - ] - (v "concatMap" `app` v "f" `app` v "nss") - -} - retstmt = - v "pure" - `app` listE - [ v "mkInstance" - `app` listE [] - -- `app` (v "con" `app` strE tcname) - `app` foldl1 - (\f x -> con "AppT" `app` f `app` x) - (v "con" `app` strE tcname : map v tvars) - `app` (v "lst") - ] diff --git a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs index 623e400e..f3b8df1a 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs @@ -15,15 +15,24 @@ module FFICXX.Generate.Code.HsTopLevel genTopLevelDef, genImportForTLOrdinary, genImportForTLTemplate, + + -- * toplevel template + genTLTemplateInterface, + genTLTemplateImplementation, + genTLTemplateInstance, ) where import Data.Either (lefts, rights) import qualified Data.List as L +import FFICXX.Generate.Code.Cpp + ( genTLTmplFunCpp, + ) import FFICXX.Generate.Code.Primitive ( CFunSig (..), HsFunSig (..), convertCpp2HS, + convertCpp2HS4Tmpl, extractArgRetTypes, ) import FFICXX.Generate.Dependency @@ -40,10 +49,19 @@ import FFICXX.Generate.Name hsFrontNameForTopLevel, typeclassName, ) -import FFICXX.Generate.Type.Class +{- import FFICXX.Generate.Type.Class ( Class (..), + TemplateClass (..), + TemplateFunction (..), + TemplateMemberFunction (..), + Types (Void), + Variable (..), + ) -} +import FFICXX.Generate.Type.Class + ( Arg (..), + Class (..), TLOrdinary (..), - TLTemplate, + TLTemplate (..), TopLevel (TLOrdinary), constructorFuncs, isAbstractClass, @@ -54,25 +72,64 @@ import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.Module ( ClassModule (..), TemplateClassModule (..), + TopLevelImportHeader (..), ) -import FFICXX.Generate.Util (toLowers) +import FFICXX.Generate.Util (firstUpper, toLowers) -- import FFICXX.Generate.Util.HaskellSrcExts - ( cxTuple, + ( bracketExp, + clsDecl, + con, + cxEmpty, + cxTuple, eabs, ethingall, evar, + generator, + inapp, + listE, + match, + mkBind1, + mkClass, mkFun, + mkFunSig, mkImport, + mkPVar, + mkTBind, mkVar, nonamespace, + op, + parenSplice, + pbind_, + qualifier, + strE, tyForall, + tySplice, + tyTupleBoxed, tyapp, tycon, tyfun, + tylist, + typeBracket, unqual, ) -import Language.Haskell.Exts.Build (app) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import Language.Haskell.Exts.Build + ( app, + binds, + caseE, + doE, + lamE, + letE, + letStmt, + pTuple, + paren, + qualStmt, + tuple, + wildcard, + ) import Language.Haskell.Exts.Syntax ( Decl, ExportSpec, @@ -191,3 +248,210 @@ genImportForTLTemplate f = tmods = L.nub $ map getTClassModuleBase $ lefts ecs in concatMap (\x -> map (\y -> mkImport (x <.> y)) ["RawType", "Cast", "Interface"]) cmods <> concatMap (\x -> map (\y -> mkImport (x <.> y)) ["Template"]) tmods + +-- +-- top-level template +-- + +genTLTemplateInterface :: TLTemplate -> [Decl ()] +genTLTemplateInterface t = + [ mkClass cxEmpty (firstUpper (topleveltfunc_name t)) (map mkTBind tps) methods + ] + where + tps = topleveltfunc_params t + ctyp = convertCpp2HS Nothing (topleveltfunc_ret t) + lst = map (convertCpp2HS Nothing . arg_type) (topleveltfunc_args t) + sigdecl = mkFunSig (topleveltfunc_name t) $ foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + methods = [clsDecl sigdecl] + +genTLTemplateImplementation :: TLTemplate -> [Decl ()] +genTLTemplateImplementation t = + mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + where + v = mkVar + p = mkPVar + itps = zip ([1 ..] :: [Int]) (topleveltfunc_params t) + tvars = map (\(i, _) -> "typ" ++ show i) itps + nparams = length itps + tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type")) + sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] + tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] + prefix = "TL" + nh = "t_" <> topleveltfunc_name t + nc = topleveltfunc_name t + lit' = strE (prefix <> "_" <> nc) + lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + rhs = + app (v "mkTFunc") $ + let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] + in tuple (typs ++ [v "suffix", lam, v "tyf"]) + sig' = + let e = error "genTLTemplateImplementation" + spls = map (tySplice . parenSplice . mkVar) $ topleveltfunc_params t + ctyp = convertCpp2HS4Tmpl e Nothing spls (topleveltfunc_ret t) + lst = map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (topleveltfunc_args t) + in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps + bstmts = + binds + [ mkBind1 + "tyf" + [wildcard] + ( letE + tassgns + (bracketExp (typeBracket sig')) + ) + Nothing + ] + +genTLTemplateInstance :: + TopLevelImportHeader -> + TLTemplate -> + [Decl ()] +genTLTemplateInstance tih t = + mkFun + fname + sig + (p "isCprim" : zipWith (\x y -> pTuple [p x, p y]) qtvars pvars) + rhs + Nothing + where + p = mkPVar + v = mkVar + tcname = firstUpper (topleveltfunc_name t) + fname = "gen" <> tcname <> "InstanceFor" + itps = zip ([1 ..] :: [Int]) (topleveltfunc_params t) + tvars = map (\(i, _) -> "typ" ++ show i) itps + qtvars = map (\(i, _) -> "qtyp" ++ show i) itps + pvars = map (\(i, _) -> "param" ++ show i) itps + nparams = length itps + typs_v = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars) + params_l = listE (map v pvars) + sig = + foldr1 tyfun $ + [tycon "IsCPrimitive"] + ++ replicate + nparams + (tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]) + ++ [tycon "Q" `tyapp` tylist (tycon "Dec")] + -- nvfs = zip ([1..] :: [Int]) vfs + + -------------------------- + -- final RHS expression -- + -------------------------- + rhs = + doE + ( [paramsstmt, suffixstmt] + <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), + letStmt + [ pbind_ + (p "callmod") + (v "dot2_" `app` v "callmod_") + ] + ] + <> map genqtypstmt (zip tvars qtvars) + <> [genstmt "f" (1 :: Int)] + <> [ foreignSrcStmt, + letStmt lststmt, + qualStmt retstmt + ] + ) + -------------------------- + paramsstmt = + letStmt + [ pbind_ + (p "params") + (v "map" `app` (v "tpinfoSuffix") `app` params_l) + ] + suffixstmt = + letStmt + [ pbind_ + (p "suffix") + ( v "concatMap" + `app` (lamE [p "x"] (inapp (strE "_") (op "++") (v "tpinfoSuffix" `app` v "x"))) + `app` params_l + ) + ] + genqtypstmt (tvar, qtvar) = generator (p tvar) (v qtvar) + genstmt prefix n = + generator + (p (prefix <> show n)) + ( v "mkFunc" + `app` strE (topleveltfunc_name t) + `app` v ("t_" <> topleveltfunc_name t) + `app` typs_v + `app` v "suffix" + ) + lststmt = [pbind_ (p "lst") (listE [v "f1"])] + -- TODO: refactor out the following code. + foreignSrcStmt = + qualifier $ + (v "addModFinalizer") + `app` ( v "addForeignSource" + `app` con "LangCxx" + `app` ( L.foldr1 + (\x y -> inapp x (op "++") y) + [ includeStatic, + {- , includeDynamic + , namespaceStr -} + strE (tcname <> "_instance"), + paren $ + caseE + (v "isCprim") + [ match (p "CPrim") (strE "_s"), + match (p "NonCPrim") (strE "") + ], + strE "(", + v "intercalate" + `app` strE ", " + `app` paren (inapp (v "callmod") (op ":") (v "params")), + strE ")\n" + ] + ) + ) + where + -- temporary + includeStatic = + strE $ + concatMap + (<> "\n") + ( [R.renderCMacro (R.Include (HdrName "MacroPatternMatch.h"))] + ++ map + R.renderCMacro + ( map R.Include (tihExtraHeadersInCPP tih) + ++ [genTLTmplFunCpp CPrim t, genTLTmplFunCpp NonCPrim t] + ) + ) + {- + cxxHeaders = v "concatMap" `app` (v "tpinfoCxxHeaders") `app` params_l + cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l + + includeDynamic = + letE + [ pbind_ (p "headers") cxxHeaders, + pbind_ + (pApp (name "f") [p "x"]) + (v "renderCMacro" `app` (con "Include" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "headers") + + namespaceStr = + letE + [ pbind_ (p "nss") cxxNamespaces, + pbind_ + (pApp (name "f") [p "x"]) + (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "nss") + -} + retstmt = + v "pure" + `app` listE + [ v "mkInstance" + `app` listE [] + -- `app` (v "con" `app` strE tcname) + `app` foldl1 + (\f x -> con "AppT" `app` f `app` x) + (v "con" `app` strE tcname : map v tvars) + `app` (v "lst") + ] diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index d9c43814..134ccff8 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -49,6 +49,7 @@ import FFICXX.Generate.Code.HsImplementation genHsFrontInstStatic, genHsFrontInstVariables, genImportInImplementation, + genTemplateMemberFunctions, ) import FFICXX.Generate.Code.HsInterface ( genHsFrontDecl, @@ -58,15 +59,13 @@ import FFICXX.Generate.Code.HsInterface ) import FFICXX.Generate.Code.HsProxy (genProxyInstance) import FFICXX.Generate.Code.HsRawType (hsClassRawType) -import FFICXX.Generate.Code.HsTemplate +import FFICXX.Generate.Code.HsTH ( genImportInTH, - genImportInTemplate, - genTLTemplateImplementation, - genTLTemplateInstance, - genTLTemplateInterface, - genTemplateMemberFunctions, genTmplImplementation, genTmplInstance, + ) +import FFICXX.Generate.Code.HsTemplate + ( genImportInTemplate, genTmplInterface, ) import FFICXX.Generate.Code.HsTopLevel @@ -75,6 +74,9 @@ import FFICXX.Generate.Code.HsTopLevel genImportForTLTemplate, genImportInModule, genImportInTopLevel, + genTLTemplateImplementation, + genTLTemplateInstance, + genTLTemplateInterface, genTopLevelDef, ) import FFICXX.Generate.Dependency @@ -127,10 +129,7 @@ import FFICXX.Generate.Util.HaskellSrcExts import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import GHC.Hs.Extension (GhcPs) -import Language.Haskell.Exts.Syntax - ( Decl, - Module, - ) +import Language.Haskell.Exts.Syntax (Module) import Language.Haskell.Syntax ( HsDecl (ForD), HsModule, From 67cbead6317641072b4ab89e84bd82a16a49415c Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Fri, 11 Aug 2023 23:22:08 -0700 Subject: [PATCH 09/19] Template member function codegen via ghc-exactprint (#219) * implement tyTupleBoxed, pTuple, lamE, tupleE, bracketExp, typeBracket * now genTMFExp is converted modulo functionSignatureTMF' * implement cxx2hsType4Tmpl (old convertCpp2HS4Tmpl) and functionSignatureTMF * now genTMFExp is fully implemented. * finally, TMF function gen is implemented! * mkBindStmt * mkLetStmt * template member function generated code works! * simple test script. add hspec-discover to the devshell dep --- experiments/sample.hs | 14 +- fficxx/src/FFICXX/Generate/Builder.hs | 3 +- fficxx/src/FFICXX/Generate/Code/HsCast.hs | 10 +- .../FFICXX/Generate/Code/HsImplementation.hs | 222 +++++++++------ .../src/FFICXX/Generate/Code/HsInterface.hs | 29 +- fficxx/src/FFICXX/Generate/Code/HsProxy.hs | 4 +- fficxx/src/FFICXX/Generate/Code/HsRawType.hs | 9 +- fficxx/src/FFICXX/Generate/Code/HsTH.hs | 1 - fficxx/src/FFICXX/Generate/Code/Primitive.hs | 48 +++- fficxx/src/FFICXX/Generate/ContentMaker.hs | 3 +- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 255 +++++++++++++----- flake.nix | 4 + workspace/build_template.sh | 8 + workspace/cabal.project | 2 + 14 files changed, 411 insertions(+), 201 deletions(-) create mode 100755 workspace/build_template.sh diff --git a/experiments/sample.hs b/experiments/sample.hs index ab1b28b5..374f01e8 100644 --- a/experiments/sample.hs +++ b/experiments/sample.hs @@ -1,16 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -w #-} module MyModule where -data K = K Int - -test :: IO () -test = do - addModFinalizer (addForeignSource LangCxx "\n#include \"test\"") - -instance (C a) => D (P a) (Q a) where - type F (P a) = Double - dinst x = x * x - -newtype Loader = Loader (Ptr RawLoader) deriving (Eq, Ord, Show) +f :: Double -> Double +f x = [1, 2] diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index b5efdd21..49bdf488 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -181,8 +181,7 @@ simpleBuilder cfg sbc = do (exactPrint (C.buildCastHs m)) -- putStrLn "Generating Implementation.hs" - for_ mods $ \m -> do - debugExactPrint (C.buildImplementationHs mempty m) + for_ mods $ \m -> gen (cmModule m <.> "Implementation" <.> "hs") (exactPrint (C.buildImplementationHs mempty m)) diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs index 29ec13f3..5f5909a9 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCast.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCast.hs @@ -23,7 +23,7 @@ import FFICXX.Generate.Util.GHCExactPrint cxEmpty, cxTuple, instD, - mkBind1, + mkBind1_, mkImport, mkInstance, mkPVar, @@ -68,7 +68,7 @@ castBody_ = castBody :: [HsBind GhcPs] castBody = - [ mkBind1 + [ mkBind1_ "cast" [mkPVar "x", mkPVar "f"] ( app @@ -84,9 +84,8 @@ castBody = ) ) ) - ) - Nothing, - mkBind1 + ), + mkBind1_ "uncast" [mkPVar "x", mkPVar "f"] ( app @@ -103,7 +102,6 @@ castBody = ) ) ) - Nothing ] genHsFrontInstCastable :: Class -> Maybe (HsDecl GhcPs) diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs index 1ed32697..ad24e617 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs @@ -16,8 +16,6 @@ module FFICXX.Generate.Code.HsImplementation -- * template member functions genTemplateMemberFunctions, - genTMFExp, - genTMFInstance, ) where @@ -59,20 +57,44 @@ import FFICXX.Generate.Type.Module ) import FFICXX.Generate.Util.GHCExactPrint ( app, + bracketExp, + con, cxEmpty, + doE, + inapp, instD, - mkBind1, + lamE, + letE, + listE, + mkBind1_, + mkBindStmt, + mkBodyStmt, mkFun, + mkFun_, mkImport, mkInstance, + mkLetStmt, + mkPVar, mkVar, + op, + pApp, + pTuple, + par, + pbind_, + strE, + toLocalBinds, + tupleE, + tyTupleBoxed, + tyapp, + tycon, + tyfun, + tylist, + typeBracket, + valBinds, ) -import qualified FFICXX.Generate.Util.HaskellSrcExts as O hiding (app, doE, listE, qualStmt, strE) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import GHC.Hs (GhcPs) -import qualified Language.Haskell.Exts.Build as O hiding (op) -import qualified Language.Haskell.Exts.Syntax as O import Language.Haskell.Syntax (HsDecl, ImportDecl) -- @@ -91,7 +113,7 @@ genHsFrontInst :: Class -> Class -> [HsDecl GhcPs] genHsFrontInst parent child | (not . isAbstractClass) child = let idecl = mkInstance cxEmpty (typeclassName parent) [cxx2HsType (Just child) SelfType] [] body - defn f = mkBind1 (hsFuncName child f) [] rhs Nothing + defn f = mkBind1_ (hsFuncName child f) [] rhs where rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f)) body = map defn . virtualFuncs . class_funcs $ parent @@ -110,13 +132,13 @@ genHsFrontInstNew c = do -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap -- newfuncann = mkComment 0 cann rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) - in mkFun (aliasedFuncName c f) (functionSignature' c f) [] rhs Nothing + in mkFun_ (aliasedFuncName c f) (functionSignature' c f) [] rhs genHsFrontInstNonVirtual :: Class -> [HsDecl GhcPs] 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 + in mkFun_ (aliasedFuncName c f) (functionSignature' c f) [] rhs where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) @@ -124,7 +146,7 @@ genHsFrontInstStatic :: Class -> [HsDecl GhcPs] 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 + in mkFun_ (aliasedFuncName c f) (functionSignature' c f) [] rhs genHsFrontInstVariables :: Class -> [HsDecl GhcPs] genHsFrontInstVariables c = @@ -133,123 +155,149 @@ genHsFrontInstVariables c = app (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1")) (mkVar (hscAccessorName c v accessor)) - in mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing - <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing + in mkFun_ (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) + <> mkFun_ (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) -- -- Template Member Function -- -genTemplateMemberFunctions :: ClassImportHeader -> [O.Decl ()] +genTemplateMemberFunctions :: ClassImportHeader -> [HsDecl GhcPs] genTemplateMemberFunctions cih = let c = cihClass cih in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c) -- TODO: combine this with genTmplInstance -genTMFExp :: Class -> TemplateMemberFunction -> [O.Decl ()] -genTMFExp c f = O.mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) +genTMFExp :: Class -> TemplateMemberFunction -> [HsDecl GhcPs] +genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs bstmts where nh = hsTemplateMemberFunctionNameTH c f - v = O.mkVar - p = O.mkPVar + v = mkVar + p = mkPVar itps = zip ([1 ..] :: [Int]) (tmf_params f) tvars = map (\(i, _) -> "typ" ++ show i) itps nparams = length itps - tparams = if nparams == 1 then O.tycon "Type" else O.tyTupleBoxed (replicate nparams (O.tycon "Type")) - sig = foldr1 O.tyfun [tparams, O.tycon "String", O.tyapp (O.tycon "Q") (O.tycon "Exp")] - tvars_p = if nparams == 1 then map p tvars else [O.pTuple (map p tvars)] - lit' = O.strE (hsTemplateMemberFunctionName c f <> "_") - lam = O.lamE [p "n"] (lit' `O.app` v "<>" `O.app` v "n") + tparams + | nparams == 1 = tycon "Type" + | otherwise = tyTupleBoxed (replicate nparams (tycon "Type")) + sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] + tvars_p + | nparams == 1 = fmap p tvars + | otherwise = [pTuple (fmap p tvars)] + lit' = strE (hsTemplateMemberFunctionName c f <> "_") + lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") rhs = - O.app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [O.tuple (map v tvars)] - in O.tuple (typs ++ [v "suffix", lam, v "tyf"]) + app (v "mkTFunc") $ + let typs + | nparams == 1 = fmap v tvars + | otherwise = [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = functionSignatureTMF c f - tassgns = map (\(i, tp) -> O.pbind_ (p tp) (v "pure" `O.app` (v ("typ" ++ show i)))) itps + tassgns = + fmap + (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) + itps bstmts = - O.binds - [ O.mkBind1 - "tyf" - [O.mkPVar "n"] - ( O.letE - tassgns - (O.bracketExp (O.typeBracket sig')) - ) - Nothing - ] + toLocalBinds True $ + valBinds + [ mkBind1_ + "tyf" + [mkPVar "n"] + ( letE + (toLocalBinds False (valBinds tassgns)) + (bracketExp (typeBracket sig')) + ) + ] -genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [O.Decl ()] +genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [HsDecl GhcPs] genTMFInstance cih f = - O.mkFun + mkFun_ fname sig - [p "isCprim", O.pTuple [p "qtyp", p "param"]] + [p "isCprim", pTuple [p "qtyp", p "param"]] rhs - Nothing where c = cihClass cih fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f - p = O.mkPVar - v = O.mkVar + p = mkPVar + v = mkVar sig = - O.tycon "IsCPrimitive" - `O.tyfun` O.tyTupleBoxed [O.tycon "Q" `O.tyapp` O.tycon "Type", O.tycon "TemplateParamInfo"] - `O.tyfun` (O.tycon "Q" `O.tyapp` O.tylist (O.tycon "Dec")) - rhs = O.doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, O.letStmt lststmt, O.qualStmt retstmt] - suffixstmt = O.letStmt [O.pbind_ (p "suffix") (v "tpinfoSuffix" `O.app` v "param")] - qtypstmt = O.generator (p "typ") (v "qtyp") + tycon "IsCPrimitive" + `tyfun` tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"] + `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec")) + rhs = + doE + [ suffixstmt, + qtypstmt, + genstmt, + foreignSrcStmt, + mkLetStmt lststmt, + mkBodyStmt retstmt + ] + suffixstmt = + mkLetStmt [pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param")] + qtypstmt = + mkBindStmt (p "typ") (v "qtyp") genstmt = - O.generator + mkBindStmt (p "f1") ( v "mkMember" - `O.app` ( O.strE (hsTemplateMemberFunctionName c f <> "_") - `O.app` v "<>" - `O.app` v "suffix" - ) - `O.app` v (hsTemplateMemberFunctionNameTH c f) - `O.app` v "typ" - `O.app` v "suffix" + `app` par + ( strE (hsTemplateMemberFunctionName c f <> "_") + `app` v "<>" + `app` v "suffix" + ) + `app` v (hsTemplateMemberFunctionNameTH c f) + `app` v "typ" + `app` v "suffix" ) - lststmt = [O.pbind_ (p "lst") (O.listE ([v "f1"]))] - retstmt = v "pure" `O.app` v "lst" + + lststmt = [pbind_ (p "lst") (listE ([v "f1"]))] + retstmt = v "pure" `app` v "lst" -- TODO: refactor out the following code. foreignSrcStmt = - O.qualifier $ + mkBodyStmt $ (v "addModFinalizer") - `O.app` ( v "addForeignSource" - `O.app` O.con "LangCxx" - `O.app` ( L.foldr1 - (\x y -> O.inapp x (O.op "++") y) - [ includeStatic, - includeDynamic, - namespaceStr, - O.strE (hsTemplateMemberFunctionName c f), - O.strE "(", - v "suffix", - O.strE ")\n" - ] - ) + `app` par + ( v "addForeignSource" + `app` con "LangCxx" + `app` par + ( L.foldr1 + (\x y -> inapp x (op "++") y) + [ par includeStatic, + par includeDynamic, + par namespaceStr, + strE (hsTemplateMemberFunctionName c f), + strE "(", + v "suffix", + strE ")\n" + ] ) + ) where includeStatic = - O.strE $ + strE $ concatMap ((<> "\n") . R.renderCMacro . R.Include) $ [HdrName "MacroPatternMatch.h", cihSelfHeader cih] <> cihIncludedHPkgHeadersInCPP cih <> cihIncludedCPkgHeaders cih includeDynamic = - O.letE - [ O.pbind_ (p "headers") (v "tpinfoCxxHeaders" `O.app` v "param"), - O.pbind_ - (O.pApp (O.name "f") [p "x"]) - (v "renderCMacro" `O.app` (O.con "Include" `O.app` v "x")) - ] - (v "concatMap" `O.app` v "f" `O.app` v "headers") + letE + ( toLocalBinds False . valBinds $ + [ pbind_ (p "headers") (v "tpinfoCxxHeaders" `app` v "param"), + pbind_ + (pApp "f" [p "x"]) + (v "renderCMacro" `app` par (con "Include" `app` v "x")) + ] + ) + (v "concatMap" `app` v "f" `app` v "headers") namespaceStr = - O.letE - [ O.pbind_ (p "nss") (v "tpinfoCxxNamespaces" `O.app` v "param"), - O.pbind_ - (O.pApp (O.name "f") [p "x"]) - (v "renderCStmt" `O.app` (O.con "UsingNamespace" `O.app` v "x")) - ] - (v "concatMap" `O.app` v "f" `O.app` v "nss") + letE + ( toLocalBinds False . valBinds $ + [ pbind_ (p "nss") (v "tpinfoCxxNamespaces" `app` v "param"), + pbind_ + (pApp "f" [p "x"]) + (v "renderCStmt" `app` par (con "UsingNamespace" `app` v "x")) + ] + ) + (v "concatMap" `app` v "f" `app` v "nss") diff --git a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs index 7929c491..faa014af 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs @@ -48,8 +48,8 @@ import FFICXX.Generate.Util.GHCExactPrint cxTuple, letE, mkClass, - mkFun, mkFunSig, + mkFun_, mkImport, mkImportSrc, mkPVar, @@ -57,7 +57,7 @@ import FFICXX.Generate.Util.GHCExactPrint mkTBind, mkTVar, mkVar, - pbind, + pbind_, qualTy, toLocalBinds, tyForall, @@ -70,7 +70,6 @@ import FFICXX.Generate.Util.GHCExactPrint import GHC.Hs (GhcPs) import Language.Haskell.Syntax ( HsDecl (TyClD), - HsLocalBindsLR (EmptyLocalBinds), ImportDecl, noExtField, ) @@ -124,7 +123,7 @@ genHsFrontDecl isHsBoot c = do genHsFrontUpcastClass :: Class -> [HsDecl GhcPs] genHsFrontUpcastClass c = - mkFun ("upcast" <> highname) typ [mkPVar "h"] rhs Nothing + mkFun_ ("upcast" <> highname) typ [mkPVar "h"] rhs where (highname, rawname) = hsClassName c hightype = tycon highname @@ -141,16 +140,14 @@ genHsFrontUpcastClass c = ) rhs = letE - ( toLocalBinds $ + ( toLocalBinds False $ valBinds - [ pbind + [ pbind_ (mkPVar "fh") - (app (mkVar "get_fptr") (mkVar "h")) - (EmptyLocalBinds noExtField), - pbind + (app (mkVar "get_fptr") (mkVar "h")), + pbind_ (mkPVarSig "fh2" (tyapp tyPtr rawtype)) (app (mkVar "castPtr") (mkVar "fh")) - (EmptyLocalBinds noExtField) ] ) (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") @@ -161,7 +158,7 @@ genHsFrontUpcastClass c = genHsFrontDowncastClass :: Class -> [HsDecl GhcPs] genHsFrontDowncastClass c = - mkFun ("downcast" <> highname) typ [mkPVar "h"] rhs Nothing + mkFun_ ("downcast" <> highname) typ [mkPVar "h"] rhs where (highname, _rawname) = hsClassName c hightype = tycon highname @@ -177,16 +174,14 @@ genHsFrontDowncastClass c = ) rhs = letE - ( toLocalBinds $ + ( toLocalBinds False $ valBinds - [ pbind + [ pbind_ (mkPVar "fh") - (app (mkVar "get_fptr") (mkVar "h")) - (EmptyLocalBinds noExtField), - pbind + (app (mkVar "get_fptr") (mkVar "h")), + pbind_ (mkPVar "fh2") (app (mkVar "castPtr") (mkVar "fh")) - (EmptyLocalBinds noExtField) ] ) (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") diff --git a/fficxx/src/FFICXX/Generate/Code/HsProxy.hs b/fficxx/src/FFICXX/Generate/Code/HsProxy.hs index fbc79932..ed314c25 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsProxy.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsProxy.hs @@ -10,7 +10,7 @@ import FFICXX.Generate.Util.GHCExactPrint inapp, listE, mkBodyStmt, - mkFun, + mkFun_, mkVar, op, par, @@ -26,7 +26,7 @@ import GHC.Hs.Extension import Language.Haskell.Syntax.Decls (HsDecl) genProxyInstance :: [HsDecl GhcPs] -genProxyInstance = mkFun fname sig [] rhs Nothing +genProxyInstance = mkFun_ fname sig [] rhs where fname = "genImplProxy" sig = tycon "Q" `tyapp` tylist (tycon "Dec") diff --git a/fficxx/src/FFICXX/Generate/Code/HsRawType.hs b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs index 25dcd34d..633b8a22 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsRawType.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs @@ -10,7 +10,7 @@ import FFICXX.Generate.Util.GHCExactPrint conDecl, cxEmpty, instD, - mkBind1, + mkBind1_, mkData, mkDeriving, mkInstance, @@ -47,12 +47,11 @@ hsClassRawType c = [hightype] [ mkTypeFamInst "Raw" [hightype] rawtype ] - [ mkBind1 + [ mkBind1_ "get_fptr" [parP (pApp highname [mkPVar "ptr"])] - (mkVar "ptr") - Nothing, - mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing + (mkVar "ptr"), + mkBind1_ "cast_fptr_to_obj" [] (con highname) ] ] where diff --git a/fficxx/src/FFICXX/Generate/Code/HsTH.hs b/fficxx/src/FFICXX/Generate/Code/HsTH.hs index fa30bf56..4202c144 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTH.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTH.hs @@ -49,7 +49,6 @@ import FFICXX.Generate.Util.HaskellSrcExts mkFun, mkImport, mkPVar, - mkTBind, mkVar, op, pbind_, diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 74abc54e..452a024f 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -834,6 +834,7 @@ cxx2HsType _c (TemplateType t) = cxx2HsType _c (TemplateParam p) = Ex.mkTVar p cxx2HsType _c (TemplateParamPointer p) = Ex.mkTVar p +-- OLD convertCpp2HS4Tmpl :: -- | self Type () -> @@ -866,6 +867,39 @@ convertCpp2HS4Tmpl e _ _ (TemplateType _) = e convertCpp2HS4Tmpl _ _ _ (TemplateParam p) = tySplice . parenSplice . mkVar $ p convertCpp2HS4Tmpl _ _ _ (TemplateParamPointer p) = tySplice . parenSplice . mkVar $ p +-- NEW +cxx2HsType4Tmpl :: + -- | self + HsType GhcPs -> + Maybe Class -> + -- | type paramemter splice + [HsType GhcPs] -> + Types -> + HsType GhcPs +cxx2HsType4Tmpl _ c _ Void = cxx2HsType c Void +cxx2HsType4Tmpl _ (Just c) _ SelfType = cxx2HsType (Just c) SelfType +cxx2HsType4Tmpl _ Nothing _ SelfType = cxx2HsType Nothing SelfType +cxx2HsType4Tmpl _ c _ x@(CT _ _) = cxx2HsType c x +cxx2HsType4Tmpl _ c _ x@(CPT (CPTClass _) _) = cxx2HsType c x +cxx2HsType4Tmpl _ c _ x@(CPT (CPTClassRef _) _) = cxx2HsType c x +cxx2HsType4Tmpl _ c _ x@(CPT (CPTClassCopy _) _) = cxx2HsType c x +cxx2HsType4Tmpl _ c _ x@(CPT (CPTClassMove _) _) = cxx2HsType c x +cxx2HsType4Tmpl _ _ ss (TemplateApp info) = + let pss = zip (tapp_tparams info) ss + in foldl1 Ex.tyapp $ + Ex.tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _, s) -> s; (p, _) -> Ex.tycon (hsClassNameForTArg p)) pss +cxx2HsType4Tmpl _ _ ss (TemplateAppRef info) = + let pss = zip (tapp_tparams info) ss + in foldl1 Ex.tyapp $ + Ex.tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _, s) -> s; (p, _) -> Ex.tycon (hsClassNameForTArg p)) pss +cxx2HsType4Tmpl _ _ ss (TemplateAppMove info) = + let pss = zip (tapp_tparams info) ss + in foldl1 Ex.tyapp $ + Ex.tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _, s) -> s; (p, _) -> Ex.tycon (hsClassNameForTArg p)) pss +cxx2HsType4Tmpl e _ _ (TemplateType _) = e +cxx2HsType4Tmpl _ _ _ (TemplateParam p) = Ex.tySplice . Ex.parenSplice . Ex.mkVar $ p +cxx2HsType4Tmpl _ _ _ (TemplateParamPointer p) = Ex.tySplice . Ex.parenSplice . Ex.mkVar $ p + hsFuncXformer :: Function -> String hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func) @@ -1091,13 +1125,15 @@ functionSignatureTT t f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) TFunOp {..} -> e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (argsFromOpExp tfun_opexp) -- TODO: rename this and combine this with functionSignatureTT -functionSignatureTMF :: Class -> TemplateMemberFunction -> Type () -functionSignatureTMF c f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) +-- NEW +functionSignatureTMF :: Class -> TemplateMemberFunction -> HsType GhcPs +functionSignatureTMF c f = + foldr1 Ex.tyfun (lst <> [Ex.tyapp (Ex.tycon "IO") ctyp]) where - spls = map (tySplice . parenSplice . mkVar) (tmf_params f) - ctyp = convertCpp2HS4Tmpl e Nothing spls (tmf_ret f) - e = tycon (fst (hsClassName c)) - lst = e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (tmf_args f) + spls = map (Ex.tySplice . Ex.parenSplice . Ex.mkVar) (tmf_params f) + ctyp = cxx2HsType4Tmpl e Nothing spls (tmf_ret f) + e = Ex.tycon (fst (hsClassName c)) + lst = e : map (cxx2HsType4Tmpl e Nothing spls . arg_type) (tmf_args f) tmplAccessorToTFun :: Variable -> Accessor -> TemplateFunction tmplAccessorToTFun v@(Variable (Arg {..})) a = diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 134ccff8..3773e21c 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -515,8 +515,7 @@ buildImplementationHs amap m = <> concatMap genHsFrontInstNonVirtual classes <> concatMap genHsFrontInstStatic classes <> concatMap genHsFrontInstVariables classes - --- <> genTemplateMemberFunctions (cmCIH m) + <> genTemplateMemberFunctions (cmCIH m) buildProxyHs :: ClassModule -> HsModule GhcPs buildProxyHs m = diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index 65f1036d..bfc34e3f 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -23,6 +23,7 @@ module FFICXX.Generate.Util.GHCExactPrint tylist, tyParen, tyPtr, + tyTupleBoxed, unit_tycon, mkTBind, @@ -34,8 +35,10 @@ module FFICXX.Generate.Util.GHCExactPrint -- * function mkFun, + mkFun_, mkFunSig, mkBind1, + mkBind1_, -- * Typeclass cxEmpty, @@ -50,6 +53,7 @@ module FFICXX.Generate.Util.GHCExactPrint mkPVar, mkPVarSig, pApp, + pTuple, parP, -- * expr @@ -57,18 +61,29 @@ module FFICXX.Generate.Util.GHCExactPrint con, doE, inapp, + lamE, letE, listE, mkVar, op, par, strE, + tupleE, valBinds, toLocalBinds, -- * stmt + mkBindStmt, mkBodyStmt, + mkLetStmt, pbind, + pbind_, + + -- * template haskell expr + bracketExp, + parenSplice, + typeBracket, + tySplice, {- app', conDecl, qualConDecl, @@ -76,7 +91,6 @@ module FFICXX.Generate.Util.GHCExactPrint lit, mkTVar, mkIVar, - pbind_, dhead, mkDeclHead, mkModuleE, @@ -87,9 +101,6 @@ module FFICXX.Generate.Util.GHCExactPrint tyParen, tyForeignPtr, classA, - tySplice, - tyTupleBoxed, - parenSplice, bracketExp, typeBracket, irule, @@ -221,17 +232,20 @@ import Language.Haskell.Syntax HsLit (..), HsLocalBinds, HsLocalBindsLR (..), - HsMatchContext (FunRhs), + HsMatchContext (FunRhs, LambdaExpr), HsModule (..), HsOuterTyVarBndrs (HsOuterImplicit), HsPatSigType (..), + HsQuote (..), HsScaled (..), HsSigType (..), HsToken (..), + HsTupArg (Present), HsTupleSort (..), HsTyVarBndr (UserTyVar), HsType (..), HsUniToken (..), + HsUntypedSplice (..), HsValBinds, HsValBindsLR (..), HsWildCardBndrs (HsWC), @@ -256,7 +270,8 @@ import Language.Haskell.Syntax noTypeArgs, ) import Language.Haskell.Syntax.Basic - ( SrcStrictness (NoSrcStrict), + ( Boxity (..), + SrcStrictness (NoSrcStrict), ) mkDeltaPos :: Int -> DeltaPos @@ -580,6 +595,12 @@ tyParen typ = tyPtr :: HsType GhcPs tyPtr = tycon "Ptr" +tyTupleBoxed :: [HsType GhcPs] -> HsType GhcPs +tyTupleBoxed typs = + HsTupleTy (mkRelEpAnn (-1) ann) HsBoxedOrConstraintTuple (tupleAnn typs) + where + ann = AnnParen AnnParens (mkEpaDelta (-1)) (mkEpaDelta (-1)) + unit_tycon :: HsType GhcPs unit_tycon = HsTupleTy (mkRelEpAnn (-1) ann) HsBoxedOrConstraintTuple [] @@ -705,14 +726,27 @@ mkFun :: -- | RHS HsExpr GhcPs -> -- | where - Maybe (HsLocalBinds GhcPs) -> + HsLocalBinds GhcPs -> -- | decls [HsDecl GhcPs] -mkFun fname typ pats rhs mbinds = +mkFun fname typ pats rhs bnds = [ SigD noExtField (mkFunSig fname typ), - ValD noExtField (mkBind1 fname pats rhs mbinds) + ValD noExtField (mkBind1 fname pats rhs bnds) ] +mkFun_ :: + -- | function name + String -> + -- | function type + HsType GhcPs -> + -- | arg pattern + [Pat GhcPs] -> + -- | RHS + HsExpr GhcPs -> + -- | decls + [HsDecl GhcPs] +mkFun_ fname typ pats rhs = mkFun fname typ pats rhs (EmptyLocalBinds noExtField) + mkFunSig :: -- | function name String -> @@ -737,38 +771,24 @@ mkBind1 :: String -> [Pat GhcPs] -> HsExpr GhcPs -> - Maybe (HsLocalBinds GhcPs) -> + HsLocalBinds GhcPs -> HsBind GhcPs -mkBind1 fname pats rhs mbinds = +mkBind1 fname pats rhs bnds = FunBind noExtField lid payload where id' = unqual (mkVarOcc fname) lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' - - lpats = fmap (mkL 0) pats - lrhs = mkL 0 rhs - glrhs = - let ann = - mkRelEpAnn - (-1) - (GrhsAnn Nothing (AddEpAnn AnnEqual (mkEpaDelta 0))) - in GRHS ann [] (lrhs) - lglrhs = L (mkRelSrcSpanAnn (-1) NoEpAnns) glrhs - match = - Match - { m_ext = mkRelEpAnn (-1) [], - m_ctxt = FunRhs lid Prefix NoSrcStrict, - m_pats = lpats, - m_grhss = - GRHSs - { grhssExt = emptyComments, - grhssGRHSs = [lglrhs], - grhssLocalBinds = EmptyLocalBinds noExtField - } - } + match = mkMatch (FunRhs lid Prefix NoSrcStrict) pats rhs bnds lmatch = mkL (-1) match payload = MG FromSource (L (mkRelSrcSpanAnn (-1) noAnnList) [lmatch]) +mkBind1_ :: + String -> + [Pat GhcPs] -> + HsExpr GhcPs -> + HsBind GhcPs +mkBind1_ fname pats rhs = mkBind1 fname pats rhs (EmptyLocalBinds noExtField) + tupleAnn :: [a] -> [GenLocated SrcSpanAnnA a] tupleAnn [] = [] tupleAnn (x : []) = [mkL (-1) x] @@ -875,12 +895,14 @@ mkInstance ctxt name typs tyfams bnds = hst_ctxt = L (mkRelSrcSpanAnn 0 annCtxt) ctxt, hst_body = mkL 0 insttyp } - annCtxt = - AnnContext - { ac_darrow = Just (NormalSyntax, mkEpaDelta 0), - ac_open = [mkEpaDelta (-1)], - ac_close = [mkEpaDelta (-1)] - } + annCtxt + | null ctxt = AnnContext Nothing [] [] + | otherwise = + AnnContext + { ac_darrow = Just (NormalSyntax, mkEpaDelta 0), + ac_open = [mkEpaDelta (-1)], + ac_close = [mkEpaDelta (-1)] + } insttyp = foldl' f (tycon name) typs where f acc x = tyapp acc (tyParen x) @@ -938,6 +960,15 @@ pApp name pats = where lpats = fmap (mkL 0) pats +pTuple :: [Pat GhcPs] -> Pat GhcPs +pTuple ps = + TuplePat (mkRelEpAnn (-1) annos) (tupleAnn ps) Boxed + where + annos = + [ AddEpAnn AnnOpenP (mkEpaDelta (-1)), + AddEpAnn AnnCloseP (mkEpaDelta (-1)) + ] + parP :: Pat GhcPs -> Pat GhcPs parP p = ParPat @@ -997,6 +1028,56 @@ inapp x o y = lo = mkL (-1) o ly = mkL (-1) y +mkMatch :: + HsMatchContext GhcPs -> + [Pat GhcPs] -> + HsExpr GhcPs -> + HsLocalBinds GhcPs -> + Match GhcPs (LHsExpr GhcPs) +mkMatch mctxt pats rhs bnds = + Match + { m_ext = mkRelEpAnn (-1) annos, + m_ctxt = mctxt, + m_pats = lpats, + m_grhss = + GRHSs + { grhssExt = emptyComments, + grhssGRHSs = [lglrhs], + grhssLocalBinds = bnds + } + } + where + annos = + case mctxt of + LambdaExpr -> [AddEpAnn AnnLam (mkEpaDelta (-1))] + _ -> [] + lpats = fmap (mkL 0) pats + lrhs = mkL 0 rhs + glrhs = + let ann = case mctxt of + LambdaExpr -> AnnRarrow + _ -> AnnEqual + ann' = + mkRelEpAnn + (-1) + (GrhsAnn Nothing (AddEpAnn ann (mkEpaDelta 0))) + in GRHS ann' [] (lrhs) + lglrhs = L (mkRelSrcSpanAnn (-1) NoEpAnns) glrhs + +lamE :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs +lamE pats expr = + HsLam noExtField grp + where + grp = MG FromSource (L (mkRelSrcSpanAnn (-1) annos) [mkL (-1) match]) + annos = + AnnList + Nothing + (Just (AddEpAnn AnnOpenP (mkEpaDelta (-1)))) + (Just (AddEpAnn AnnCloseP (mkEpaDelta (-1)))) + [] -- [AddEpAnn AnnLam (mkEpaDelta (-1))] + [] + match = mkMatch LambdaExpr pats expr (EmptyLocalBinds noExtField) + letE :: HsLocalBinds GhcPs -> HsExpr GhcPs -> HsExpr GhcPs letE bnds expr = HsLet (mkRelEpAnn' (DifferentLine 1 2) NoEpAnns) tokLet bnds tokIn (mkL 0 expr) @@ -1013,11 +1094,9 @@ listE itms = let ann = AnnList Nothing - Nothing - Nothing - [ AddEpAnn AnnOpenS (EpaDelta (SameLine 0) []), - AddEpAnn AnnCloseS (EpaDelta (SameLine 0) []) - ] + (Just (AddEpAnn AnnOpenS (mkEpaDelta (-1)))) + (Just (AddEpAnn AnnCloseS (mkEpaDelta (-1)))) + [] [] litms = fmap (mkL (-1)) itms in ExplicitList (mkRelEpAnn (-1) ann) litms @@ -1038,6 +1117,8 @@ par expr = tokOpen = L (tokLoc (-1)) HsTok tokClose = L (tokLoc (-1)) HsTok +infixl 2 `par` + strE :: String -> HsExpr GhcPs strE str = HsLit ann1 (HsString ann2 (fromString str)) where @@ -1045,26 +1126,60 @@ strE str = HsLit ann1 (HsString ann2 (fromString str)) ann1 = mkRelEpAnn (-1) NoEpAnns ann2 = SourceText str' +tupleE :: [HsExpr GhcPs] -> HsExpr GhcPs +tupleE exprs = + ExplicitTuple (mkRelEpAnn (-1) annos) args Boxed + where + annos = + [ AddEpAnn AnnOpenP (mkEpaDelta (-1)), + AddEpAnn AnnCloseP (mkEpaDelta (-1)) + ] + mkArg = Present EpAnnNotUsed + args = fmap mkArg $ tupleAnn exprs + valBinds :: [HsBind GhcPs] -> HsValBinds GhcPs valBinds bnds = ValBinds NoAnnSortKey (listToBag lbnds) [] where lbnds = paragraphLines' (SameLine 2) bnds -toLocalBinds :: HsValBinds GhcPs -> HsLocalBinds GhcPs -toLocalBinds = - HsValBinds (mkRelEpAnn' (DifferentLine 1 2) noAnnList) +toLocalBinds :: Bool -> HsValBinds GhcPs -> HsLocalBinds GhcPs +toLocalBinds withWhere = + HsValBinds (mkRelEpAnn' (DifferentLine 1 2) ann) + where + ann + | withWhere = + AnnList + Nothing + Nothing + Nothing + [AddEpAnn AnnWhere (mkEpaDelta (-1))] + [] + | otherwise = noAnnList -- -- Statements -- +mkBindStmt :: Pat GhcPs -> HsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkBindStmt pat expr = + BindStmt (mkRelEpAnn (-1) annos) (mkL (-1) pat) (mkL 0 expr) + where + annos = + [AddEpAnn AnnLarrow (mkEpaDelta 0)] + mkBodyStmt :: HsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) mkBodyStmt expr = BodyStmt noExtField body noExtField noExtField where body = mkL (-1) expr +mkLetStmt :: [HsBind GhcPs] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkLetStmt bnds = + LetStmt (mkRelEpAnn (-1) annos) (toLocalBinds False $ valBinds bnds) + where + annos = [AddEpAnn AnnLet (mkEpaDelta (-1))] + pbind :: Pat GhcPs -> HsExpr GhcPs -> HsLocalBinds GhcPs -> HsBind GhcPs pbind pat expr bnds = PatBind (mkRelEpAnn (-1) []) (mkL (-1) pat) grhss @@ -1074,6 +1189,37 @@ pbind pat expr bnds = grhs = GRHS (mkRelEpAnn (-1) ann) [] (mkL 0 expr) ann = GrhsAnn Nothing (AddEpAnn AnnEqual (mkEpaDelta 0)) +pbind_ :: Pat GhcPs -> HsExpr GhcPs -> HsBind GhcPs +pbind_ p e = pbind p e (EmptyLocalBinds noExtField) + +-- +-- template haskell expr +-- + +bracketExp :: HsQuote GhcPs -> HsExpr GhcPs +bracketExp quote = + HsUntypedBracket (mkRelEpAnn (-1) annos) quote + where + annos = + [ AddEpAnn AnnOpen (mkEpaDelta (-1)), + AddEpAnn AnnCloseQ (mkEpaDelta (-1)) + ] + +parenSplice :: HsExpr GhcPs -> HsUntypedSplice GhcPs +parenSplice expr = + HsUntypedSpliceExpr (mkRelEpAnn (-1) annos) (mkL (-1) expr) + where + annos = + [ AddEpAnn AnnDollar (mkEpaDelta (-1)) + ] + +typeBracket :: HsType GhcPs -> HsQuote GhcPs +typeBracket typ = + TypBr noExtField (mkL (-1) typ) + +tySplice :: HsUntypedSplice GhcPs -> HsType GhcPs +tySplice sp = HsSpliceTy noExtField sp + -- -- utilities -- @@ -1213,9 +1359,6 @@ lit = Lit () mkIVar :: String -> ImportSpec () mkIVar = IVar () . Ident () -pbind_ :: Pat () -> Exp () -> Decl () -pbind_ p e = pbind p e Nothing - dhead :: String -> DeclHead () dhead n = DHead () (Ident () n) @@ -1240,18 +1383,6 @@ x `dot` y = x `app` mkVar "." `app` y tyForeignPtr :: Type () tyForeignPtr = tycon "ForeignPtr" -tySplice :: Splice () -> Type () -tySplice = TySplice () - -tyTupleBoxed :: [Type ()] -> Type () -tyTupleBoxed = TyTuple () LHE.Boxed - -parenSplice :: Exp () -> Splice () -parenSplice = ParenSplice () - -bracketExp :: Bracket () -> Exp () -bracketExp = BracketExp () - typeBracket :: Type () -> Bracket () typeBracket = TypeBracket () diff --git a/flake.nix b/flake.nix index 381350ca..29726f58 100644 --- a/flake.nix +++ b/flake.nix @@ -63,6 +63,10 @@ (p: [ p.sphinx p.sphinx_rtd_theme p.myst-parser ]); in (hpkgsFor compiler).shellFor { packages = ps: [ ps.fficxx ps.fficxx-runtime ]; + extraDependencies = ps: { + libraryHaskellDepends = [ ps.hspec-discover ]; + }; + buildInputs = [ pkgs.cabal-install pkgs.ormolu pkgs.nixfmt pyenv ]; withHoogle = false; shellHook = '' diff --git a/workspace/build_template.sh b/workspace/build_template.sh new file mode 100755 index 00000000..10af8de6 --- /dev/null +++ b/workspace/build_template.sh @@ -0,0 +1,8 @@ +cabal build fficxx && \ + cabal exec -- runhaskell ../fficxx-multipkg-test/template-member/Gen.hs ../fficxx-multipkg-test/template-member/template && \ + cabal exec -- runhaskell ../fficxx-multipkg-test/template-dep/Gen.hs ../fficxx-multipkg-test/template-dep/template && \ + cabal exec -- runhaskell ../fficxx-multipkg-test/template-toplevel/Gen.hs ../fficxx-multipkg-test/template-toplevel/template && \ + cabal build tmf-test && \ + cabal build tmpl-dep-test && \ + cabal build tmpl-toplevel-test && \ + cabal test fficxx-multipkg-test diff --git a/workspace/cabal.project b/workspace/cabal.project index cd9e16ca..69777636 100644 --- a/workspace/cabal.project +++ b/workspace/cabal.project @@ -5,5 +5,7 @@ packages: optional-packages: ./stdcxx/ ../fficxx-test/ + ../fficxx-multipkg-test/ + ./tmf-test/ ./tmpl-dep-test/ ./tmpl-toplevel-test/ From 671af5af684baafb98899493da000d786c35a6b0 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Sat, 12 Aug 2023 03:48:50 -0700 Subject: [PATCH 10/19] Template and TH codegen via ghc-exactprint (#220) and now only top-level function generations are left. * HsTemplate! * convert genTmplImplementation * TH code gen successful! * fix further * remove old functionSignature.. --- fficxx/src/FFICXX/Generate/Builder.hs | 4 +- fficxx/src/FFICXX/Generate/Code/HsCast.hs | 14 -- .../FFICXX/Generate/Code/HsImplementation.hs | 8 +- .../src/FFICXX/Generate/Code/HsInterface.hs | 4 +- fficxx/src/FFICXX/Generate/Code/HsRawType.hs | 3 +- fficxx/src/FFICXX/Generate/Code/HsTH.hs | 192 +++++++++--------- fficxx/src/FFICXX/Generate/Code/HsTemplate.hs | 67 +++--- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 70 +++---- fficxx/src/FFICXX/Generate/ContentMaker.hs | 47 ++--- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 90 ++++---- 10 files changed, 252 insertions(+), 247 deletions(-) diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 49bdf488..8a24cd27 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -197,13 +197,13 @@ simpleBuilder cfg sbc = do for_ tcms $ \m -> gen (tcmModule m <.> "Template" <.> "hs") - (prettyPrint (C.buildTemplateHs m)) + (exactPrint (C.buildTemplateHs m)) -- putStrLn "Generating TH.hs" for_ tcms $ \m -> gen (tcmModule m <.> "TH" <.> "hs") - (prettyPrint (C.buildTHHs m)) + (exactPrint (C.buildTHHs m)) -- -- TODO: Template.hs-boot need to be generated as well putStrLn "Generating hs-boot file" diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs index 5f5909a9..de836714 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsCast.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsCast.hs @@ -4,7 +4,6 @@ module FFICXX.Generate.Code.HsCast -- * code castBody, - castBody_, genHsFrontInstCastable, genHsFrontInstCastableSelf, ) @@ -34,15 +33,7 @@ import FFICXX.Generate.Util.GHCExactPrint tyapp, tycon, ) -import qualified FFICXX.Generate.Util.HaskellSrcExts as O - ( app, - insDecl, - mkBind1, - mkPVar, - mkVar, - ) import GHC.Hs (GhcPs) -import qualified Language.Haskell.Exts.Syntax as O (InstDecl) import Language.Haskell.Syntax ( HsBind, HsDecl, @@ -60,11 +51,6 @@ genImportInCast m = -- -- code -- -castBody_ :: [O.InstDecl ()] -castBody_ = - [ O.insDecl (O.mkBind1 "cast" [O.mkPVar "x", O.mkPVar "f"] (O.app (O.mkVar "f") (O.app (O.mkVar "castPtr") (O.app (O.mkVar "get_fptr") (O.mkVar "x")))) Nothing), - O.insDecl (O.mkBind1 "uncast" [O.mkPVar "x", O.mkPVar "f"] (O.app (O.mkVar "f") (O.app (O.mkVar "cast_fptr_to_obj") (O.app (O.mkVar "castPtr") (O.mkVar "x")))) Nothing) - ] castBody :: [HsBind GhcPs] castBody = diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs index ad24e617..0e536146 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs @@ -24,7 +24,7 @@ import qualified Data.List as L (foldr1) import FFICXX.Generate.Code.Primitive ( accessorSignature, cxx2HsType, - functionSignature', + functionSignature, functionSignatureTMF, hsFuncXformer, ) @@ -132,13 +132,13 @@ genHsFrontInstNew c = do -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap -- newfuncann = mkComment 0 cann rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) - in mkFun_ (aliasedFuncName c f) (functionSignature' c f) [] rhs + in mkFun_ (aliasedFuncName c f) (functionSignature c f) [] rhs genHsFrontInstNonVirtual :: Class -> [HsDecl GhcPs] 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 + in mkFun_ (aliasedFuncName c f) (functionSignature c f) [] rhs where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) @@ -146,7 +146,7 @@ genHsFrontInstStatic :: Class -> [HsDecl GhcPs] 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 + in mkFun_ (aliasedFuncName c f) (functionSignature c f) [] rhs genHsFrontInstVariables :: Class -> [HsDecl GhcPs] genHsFrontInstVariables c = diff --git a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs index faa014af..77f2af8d 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs @@ -21,7 +21,7 @@ import qualified Data.List as L import qualified Data.List.NonEmpty as NE import FFICXX.Generate.Code.Primitive ( classConstraints, - functionSignature', + functionSignature, ) import FFICXX.Generate.Dependency.Graph ( getCyclicDepSubmodules, @@ -111,7 +111,7 @@ genHsFrontDecl isHsBoot c = do let cdecl = TyClD noExtField (mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body) -- for hs-boot, we only have instance head. cdecl' = TyClD noExtField (mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] []) - sigdecl f = mkFunSig (hsFuncName c f) (functionSignature' c f) + sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) body = map sigdecl . virtualFuncs . class_funcs $ c if isHsBoot then return cdecl' diff --git a/fficxx/src/FFICXX/Generate/Code/HsRawType.hs b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs index 633b8a22..2aa47ff1 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsRawType.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs @@ -32,11 +32,12 @@ import Language.Haskell.Syntax hsClassRawType :: Class -> [HsDecl GhcPs] hsClassRawType c = - [ TyClD noExtField (mkData rawname [] []), + [ TyClD noExtField (mkData rawname [] [] []), TyClD noExtField ( mkNewtype highname + [] (conDecl highname [tyapp tyPtr rawtype]) deriv ), diff --git a/fficxx/src/FFICXX/Generate/Code/HsTH.hs b/fficxx/src/FFICXX/Generate/Code/HsTH.hs index 4202c144..d48c7cf7 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTH.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTH.hs @@ -39,54 +39,52 @@ import FFICXX.Generate.Type.Module ( TemplateClassImportHeader (..), TemplateClassSubmoduleType (..), ) -import FFICXX.Generate.Util.HaskellSrcExts - ( bracketExp, +import FFICXX.Generate.Util.GHCExactPrint + ( app, + bracketExp, + caseE, con, - generator, + doE, inapp, - match, - mkBind1, + lamE, + letE, + listE, + mkBind1_, + mkBindStmt, + mkBodyStmt, mkFun, + mkFun_, mkImport, + mkLetStmt, mkPVar, mkVar, op, + pApp, + pTuple, + par, pbind_, - qualifier, + strE, + toLocalBinds, + tupleE, tyTupleBoxed, tyapp, tycon, tyfun, tylist, typeBracket, + valBinds, + wildcard, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) -import Language.Haskell.Exts.Build - ( app, - binds, - caseE, - doE, - lamE, - letE, - letStmt, - listE, - name, - pApp, - pTuple, - paren, - qualStmt, - strE, - tuple, - wildcard, - ) -import Language.Haskell.Exts.Syntax - ( Decl, +import GHC.Hs (GhcPs) +import Language.Haskell.Syntax + ( HsDecl, ImportDecl, ) -genImportInTH :: TemplateClass -> [ImportDecl ()] +genImportInTH :: TemplateClass -> [ImportDecl GhcPs] genImportInTH t0 = fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0) @@ -94,7 +92,7 @@ genImportInTH t0 = -- implementation -- -genTmplImplementation :: TemplateClass -> [Decl ()] +genTmplImplementation :: TemplateClass -> [HsDecl GhcPs] genTmplImplementation t = concatMap gen (tclass_funcs t) ++ concatMap genV (tclass_vars t) where @@ -107,7 +105,7 @@ genTmplImplementation t = sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")] tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] prefix = tclass_name t - gen f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + gen f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs bstmts where nh = hsTmplFuncNameTH t f nc = ffiTmplFuncName f @@ -115,21 +113,24 @@ genTmplImplementation t = lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") rhs = app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] - in tuple (typs ++ [v "suffix", lam, v "tyf"]) + let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = functionSignatureTT t f - tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps + tassgns = + fmap + (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) + itps bstmts = - binds - [ mkBind1 - "tyf" - [wildcard] - ( letE - tassgns - (bracketExp (typeBracket sig')) - ) - Nothing - ] + toLocalBinds True $ + valBinds + [ mkBind1_ + "tyf" + [wildcard] + ( letE + (toLocalBinds False (valBinds tassgns)) + (bracketExp (typeBracket sig')) + ) + ] genV vf = let f_g = tmplAccessorToTFun vf Getter f_s = tmplAccessorToTFun vf Setter @@ -137,14 +138,13 @@ genTmplImplementation t = genTmplInstance :: TemplateClassImportHeader -> - [Decl ()] + [HsDecl GhcPs] genTmplInstance tcih = - mkFun + mkFun_ fname sig (p "isCprim" : zipWith (\x y -> pTuple [p x, p y]) qtvars pvars) rhs - Nothing where t = tcihTClass tcih fs = tclass_funcs t @@ -158,7 +158,7 @@ genTmplInstance tcih = qtvars = map (\(i, _) -> "qtyp" ++ show i) itps pvars = map (\(i, _) -> "param" ++ show i) itps nparams = length itps - typs_v = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars) + typs_v = if nparams == 1 then v (tvars !! 0) else tupleE (map v tvars) params_l = listE (map v pvars) sig = foldr1 tyfun $ @@ -175,27 +175,27 @@ genTmplInstance tcih = rhs = doE ( [paramsstmt, suffixstmt] - <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), - letStmt + <> [ mkBindStmt (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), + mkLetStmt [ pbind_ (p "callmod") (v "dot2_" `app` v "callmod_") ] ] - <> map genqtypstmt (zip tvars qtvars) - <> map genstmt nfs + <> fmap genqtypstmt (zip tvars qtvars) + <> fmap genstmt nfs <> concatMap genvarstmt nvfs - <> [foreignSrcStmt, letStmt lststmt, qualStmt retstmt] + <> [foreignSrcStmt, mkLetStmt lststmt, mkBodyStmt retstmt] ) -------------------------- paramsstmt = - letStmt + mkLetStmt [ pbind_ (p "params") (v "map" `app` (v "tpinfoSuffix") `app` params_l) ] suffixstmt = - letStmt + mkLetStmt [ pbind_ (p "suffix") ( v "concatMap" @@ -203,9 +203,9 @@ genTmplInstance tcih = `app` params_l ) ] - genqtypstmt (tvar, qtvar) = generator (p tvar) (v qtvar) + genqtypstmt (tvar, qtvar) = mkBindStmt (p tvar) (v qtvar) gen prefix nm f n = - generator + mkBindStmt (p (prefix <> show n)) ( v nm `app` strE (hsTmplFuncName t f) @@ -248,30 +248,32 @@ genTmplInstance tcih = ] -- TODO: refactor out the following code. foreignSrcStmt = - qualifier $ + mkBodyStmt $ (v "addModFinalizer") - `app` ( v "addForeignSource" - `app` con "LangCxx" - `app` ( L.foldr1 - (\x y -> inapp x (op "++") y) - [ includeStatic, - includeDynamic, - namespaceStr, - strE (tname <> "_instance"), - paren $ - caseE - (v "isCprim") - [ match (p "CPrim") (strE "_s"), - match (p "NonCPrim") (strE "") - ], - strE "(", - v "intercalate" - `app` strE ", " - `app` paren (inapp (v "callmod") (op ":") (v "params")), - strE ")\n" - ] - ) - ) + `app` par + ( v "addForeignSource" + `app` con "LangCxx" + `app` par + ( L.foldr1 + (\x y -> inapp x (op "++") y) + [ includeStatic, + par includeDynamic, + par namespaceStr, + strE (tname <> "_instance"), + par $ + caseE + (v "isCprim") + [ (p "CPrim", strE "_s"), + (p "NonCPrim", strE "") + ], + strE "(", + v "intercalate" + `app` strE ", " + `app` par (inapp (v "callmod") (op ":") (v "params")), + strE ")\n" + ] + ) + ) where -- temporary body = @@ -295,27 +297,35 @@ genTmplInstance tcih = cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l includeDynamic = letE - [ pbind_ (p "headers") cxxHeaders, - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCMacro" `app` (con "Include" `app` v "x")) - ] + ( toLocalBinds False $ + valBinds $ + [ pbind_ (p "headers") cxxHeaders, + pbind_ + (pApp "f" [p "x"]) + (v "renderCMacro" `app` par (con "Include" `app` v "x")) + ] + ) (v "concatMap" `app` v "f" `app` v "headers") namespaceStr = letE - [ pbind_ (p "nss") cxxNamespaces, - pbind_ - (pApp (name "f") [p "x"]) - (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) - ] + ( toLocalBinds False $ + valBinds $ + [ pbind_ (p "nss") cxxNamespaces, + pbind_ + (pApp "f" [p "x"]) + (v "renderCStmt" `app` (par (con "UsingNamespace" `app` v "x"))) + ] + ) (v "concatMap" `app` v "f" `app` v "nss") retstmt = v "pure" `app` listE [ v "mkInstance" `app` listE [] - `app` foldl1 - (\f x -> con "AppT" `app` f `app` x) - (v "con" `app` strE (typeclassNameT t) : map v tvars) + `app` par + ( foldl1 + (\f x -> par (con "AppT" `app` f `app` x)) + (par (v "con" `app` strE (typeclassNameT t)) : map v tvars) + ) `app` (v "lst") ] diff --git a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs index 7529dfee..53b6b7a9 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs @@ -7,7 +7,7 @@ module FFICXX.Generate.Code.HsTemplate ) where -import FFICXX.Generate.Code.HsCast (castBody_) +import FFICXX.Generate.Code.HsCast (castBody) import FFICXX.Generate.Code.Primitive ( functionSignatureT, tmplAccessorToTFun, @@ -26,14 +26,12 @@ import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.Module ( TemplateClassSubmoduleType (..), ) -import FFICXX.Generate.Util.HaskellSrcExts - ( clsDecl, - con, +import FFICXX.Generate.Util.GHCExactPrint + ( con, conDecl, cxEmpty, - insDecl, - insType, - mkBind1, + instD, + mkBind1_, mkClass, mkData, mkFunSig, @@ -43,36 +41,41 @@ import FFICXX.Generate.Util.HaskellSrcExts mkPVar, mkTBind, mkTVar, + mkTypeFamInst, mkVar, - qualConDecl, + pApp, + parP, + tyParen, tyPtr, tyapp, tycon, ) -import Language.Haskell.Exts.Build - ( name, - pApp, - ) -import Language.Haskell.Exts.Syntax - ( Decl, +import GHC.Hs (GhcPs) +import Language.Haskell.Syntax + ( HsDecl (TyClD), ImportDecl, + noExtField, ) -genImportInTemplate :: TemplateClass -> [ImportDecl ()] +genImportInTemplate :: TemplateClass -> [ImportDecl GhcPs] genImportInTemplate t0 = fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTemplate, t0) -genTmplInterface :: TemplateClass -> [Decl ()] +genTmplInterface :: TemplateClass -> [HsDecl GhcPs] genTmplInterface t = - [ mkData rname (map mkTBind tps) [] Nothing, - mkNewtype - hname - (map mkTBind tps) - [qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype])] - Nothing, - mkClass cxEmpty (typeclassNameT t) (map mkTBind tps) methods, - mkInstance cxEmpty "FPtr" [hightype] fptrbody, - mkInstance cxEmpty "Castable" [hightype, tyapp tyPtr rawtype] castBody_ + [ TyClD noExtField (mkData rname (fmap mkTBind tps) [] []), + TyClD noExtField $ + mkNewtype + hname + (fmap mkTBind tps) + (conDecl hname [tyParen (tyapp tyPtr (tyParen rawtype))]) + [], + TyClD noExtField $ + mkClass cxEmpty (typeclassNameT t) (fmap mkTBind tps) methods, + instD $ + mkInstance cxEmpty "FPtr" [hightype] fptrfam fptrbody, + instD $ + mkInstance cxEmpty "Castable" [hightype, tyapp tyPtr (tyParen rawtype)] [] castBody ] where (hname, rname) = hsTemplateClassName t @@ -86,9 +89,15 @@ genTmplInterface t = let f_g = tmplAccessorToTFun vf Getter f_s = tmplAccessorToTFun vf Setter in [sigdecl f_g, sigdecl f_s] - methods = map (clsDecl . sigdecl) fs ++ (map clsDecl . concatMap sigdeclV) vfs + methods = fmap sigdecl fs ++ concatMap sigdeclV vfs + fptrfam = [mkTypeFamInst "Raw" [tyParen hightype] rawtype] 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) + [ mkBind1_ + "get_fptr" + [parP (pApp hname [mkPVar "ptr"])] + (mkVar "ptr"), + mkBind1_ + "cast_fptr_to_obj" + [] + (con hname) ] diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 452a024f..6fa153a8 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -1054,24 +1054,8 @@ extractArgRetTypes' mc isvirtual (CFunSig args ret) = Void -> pure Ex.unit_tycon _ -> error ("No such c type : " <> show typ) --- OLD -functionSignature :: Class -> Function -> Type () +functionSignature :: Class -> Function -> HsType GhcPs functionSignature c f = - let HsFunSig typs assts = - extractArgRetTypes - (Just c) - (isVirtualFunc f) - (CFunSig (genericFuncArgs f) (genericFuncRet f)) - ctxt = cxTuple assts - arg0 - | isVirtualFunc f = (mkTVar "a" :) - | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :) - | otherwise = id - in tyForall Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) - --- NEW -functionSignature' :: Class -> Function -> HsType GhcPs -functionSignature' c f = let HsFunSig' typs assts = extractArgRetTypes' (Just c) @@ -1084,48 +1068,48 @@ functionSignature' c f = | otherwise = id in Ex.qualTy ctxt (foldr1 Ex.tyfun (arg0 typs)) -functionSignatureT :: TemplateClass -> TemplateFunction -> Type () +-- NEW +functionSignatureT :: TemplateClass -> TemplateFunction -> HsType GhcPs functionSignatureT t TFun {..} = let (hname, _) = hsTemplateClassName t - slf = foldl1 tyapp (tycon hname : map mkTVar (tclass_params t)) - ctyp = convertCpp2HS Nothing tfun_ret - lst = slf : map (convertCpp2HS Nothing . arg_type) tfun_args - in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + slf = foldl1 Ex.tyapp (Ex.tycon hname : map Ex.mkTVar (tclass_params t)) + ctyp = cxx2HsType Nothing tfun_ret + lst = slf : map (cxx2HsType Nothing . arg_type) tfun_args + in foldr1 Ex.tyfun (lst <> [Ex.tyapp (Ex.tycon "IO") (Ex.tyParen ctyp)]) functionSignatureT t TFunNew {..} = - let ctyp = convertCpp2HS Nothing (TemplateType t) - lst = map (convertCpp2HS Nothing . arg_type) tfun_new_args - in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + let ctyp = cxx2HsType Nothing (TemplateType t) + lst = map (cxx2HsType Nothing . arg_type) tfun_new_args + in foldr1 Ex.tyfun (lst <> [Ex.tyapp (Ex.tycon "IO") (Ex.tyParen ctyp)]) functionSignatureT t TFunDelete = - let ctyp = convertCpp2HS Nothing (TemplateType t) - in ctyp `tyfun` (tyapp (tycon "IO") unit_tycon) + let ctyp = cxx2HsType Nothing (TemplateType t) + in ctyp `Ex.tyfun` (Ex.tyapp (Ex.tycon "IO") Ex.unit_tycon) functionSignatureT t TFunOp {..} = let (hname, _) = hsTemplateClassName t - slf = foldl1 tyapp (tycon hname : map mkTVar (tclass_params t)) - ctyp = convertCpp2HS Nothing tfun_ret - lst = slf : map (convertCpp2HS Nothing . arg_type) (argsFromOpExp tfun_opexp) - in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + slf = foldl1 Ex.tyapp (Ex.tycon hname : fmap Ex.mkTVar (tclass_params t)) + ctyp = cxx2HsType Nothing tfun_ret + lst = slf : map (cxx2HsType Nothing . arg_type) (argsFromOpExp tfun_opexp) + in foldr1 Ex.tyfun (lst <> [Ex.tyapp (Ex.tycon "IO") (Ex.tyParen ctyp)]) -- TODO: rename this and combine this with functionSignatureTMF -functionSignatureTT :: TemplateClass -> TemplateFunction -> Type () -functionSignatureTT t f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) +functionSignatureTT :: TemplateClass -> TemplateFunction -> HsType GhcPs +functionSignatureTT t f = foldr1 Ex.tyfun (lst <> [Ex.tyapp (Ex.tycon "IO") (Ex.tyParen ctyp)]) where (hname, _) = hsTemplateClassName t ctyp = case f of - TFun {..} -> convertCpp2HS4Tmpl e Nothing spls tfun_ret - TFunNew {} -> convertCpp2HS4Tmpl e Nothing spls (TemplateType t) - TFunDelete -> unit_tycon - TFunOp {..} -> convertCpp2HS4Tmpl e Nothing spls tfun_ret - e = foldl1 tyapp (tycon hname : spls) - spls = map (tySplice . parenSplice . mkVar) $ tclass_params t + TFun {..} -> cxx2HsType4Tmpl e Nothing spls tfun_ret + TFunNew {} -> cxx2HsType4Tmpl e Nothing spls (TemplateType t) + TFunDelete -> Ex.unit_tycon + TFunOp {..} -> cxx2HsType4Tmpl e Nothing spls tfun_ret + e = foldl1 Ex.tyapp (Ex.tycon hname : spls) + spls = map (Ex.tySplice . Ex.parenSplice . Ex.mkVar) $ tclass_params t lst = case f of - TFun {..} -> e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) tfun_args - TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spls . arg_type) tfun_new_args + TFun {..} -> e : map (cxx2HsType4Tmpl e Nothing spls . arg_type) tfun_args + TFunNew {..} -> map (cxx2HsType4Tmpl e Nothing spls . arg_type) tfun_new_args TFunDelete -> [e] - TFunOp {..} -> e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (argsFromOpExp tfun_opexp) + TFunOp {..} -> e : map (cxx2HsType4Tmpl e Nothing spls . arg_type) (argsFromOpExp tfun_opexp) -- TODO: rename this and combine this with functionSignatureTT --- NEW functionSignatureTMF :: Class -> TemplateMemberFunction -> HsType GhcPs functionSignatureTMF c f = foldr1 Ex.tyfun (lst <> [Ex.tyapp (Ex.tycon "IO") ctyp]) diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 3773e21c..380cc627 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -122,7 +122,6 @@ import FFICXX.Generate.Util.HaskellSrcExts evar, lang, mkImport, - mkModule, mkModuleE, unqual, ) @@ -535,43 +534,41 @@ buildProxyHs m = where body = genProxyInstance -buildTemplateHs :: TemplateClassModule -> Module () +buildTemplateHs :: TemplateClassModule -> HsModule GhcPs buildTemplateHs m = - mkModule + Ex.mkModule (tcmModule m <.> "Template") - [ lang - [ "EmptyDataDecls", - "FlexibleInstances", - "MultiParamTypeClasses", - "TypeFamilies" - ] + [ "EmptyDataDecls", + "FlexibleInstances", + "MultiParamTypeClasses", + "TypeFamilies" ] imports body where t = tcihTClass $ tcmTCIH m imports = - [ mkImport "Foreign.C.Types", - mkImport "Foreign.Ptr", - mkImport "FFICXX.Runtime.Cast" + [ Ex.mkImport "Foreign.C.Types", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport "FFICXX.Runtime.Cast" ] <> genImportInTemplate t body = genTmplInterface t -buildTHHs :: TemplateClassModule -> Module () +buildTHHs :: TemplateClassModule -> HsModule GhcPs buildTHHs m = - mkModule + Ex.mkModule (tcmModule m <.> "TH") - [lang ["TemplateHaskell"]] - ( [ mkImport "Data.Char", - mkImport "Data.List", - mkImport "Data.Monoid", - mkImport "Foreign.C.Types", - mkImport "Foreign.Ptr", - mkImport "Language.Haskell.TH", - mkImport "Language.Haskell.TH.Syntax", - mkImport "FFICXX.Runtime.CodeGen.Cxx", - mkImport "FFICXX.Runtime.TH" + ["TemplateHaskell"] + ( [ Ex.mkImport "Data.Char", + Ex.mkImport "Data.List", + Ex.mkImport "Data.Monoid", + Ex.mkImport "Foreign.C.Types", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport "Language.Haskell.TH", + Ex.mkImport "Language.Haskell.TH.Syntax", + Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", + Ex.mkImport "FFICXX.Runtime.TH" ] <> imports ) @@ -579,7 +576,7 @@ buildTHHs m = where t = tcihTClass $ tcmTCIH m imports = - [mkImport (tcmModule m <.> "Template")] + [Ex.mkImport (tcmModule m <.> "Template")] <> genImportInTH t body = tmplImpls <> tmplInsts tmplImpls = genTmplImplementation t diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index bfc34e3f..b638d97d 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -55,9 +55,11 @@ module FFICXX.Generate.Util.GHCExactPrint pApp, pTuple, parP, + wildcard, -- * expr app, + caseE, con, doE, inapp, @@ -134,6 +136,7 @@ import GHC.Data.Bag (emptyBag, listToBag) import GHC.Hs ( AnnSig (..), AnnsModule (..), + EpAnnHsCase (..), GhcPs, GrhsAnn (..), XImportDeclPass (..), @@ -232,7 +235,7 @@ import Language.Haskell.Syntax HsLit (..), HsLocalBinds, HsLocalBindsLR (..), - HsMatchContext (FunRhs, LambdaExpr), + HsMatchContext (CaseAlt, FunRhs, LambdaExpr), HsModule (..), HsOuterTyVarBndrs (HsOuterImplicit), HsPatSigType (..), @@ -617,17 +620,17 @@ mkTBind name = UserTyVar (mkRelEpAnn (-1) []) () (mkLIdP (-1) name) mkData :: -- | data type name String -> - -- [TyVarBind ()] -> + [HsTyVarBndr () GhcPs] -> [ConDecl GhcPs] -> HsDeriving GhcPs -> TyClDecl GhcPs -mkData name {- tbinds -} cdecls deriv = +mkData name tbinds cdecls deriv = DataDecl (mkRelEpAnn (-1) annos) (mkLIdP 0 name) qty Prefix dfn where annos = [ AddEpAnn AnnData (mkEpaDelta (-1)) ] - qty = HsQTvs noExtField [] + qty = HsQTvs noExtField $ fmap (mkL 0) tbinds dfn = HsDataDefn { dd_ext = noExtField, @@ -641,18 +644,18 @@ mkData name {- tbinds -} cdecls deriv = mkNewtype :: -- | newtype name String -> - -- [TyVarBind ()] -> + [HsTyVarBndr () GhcPs] -> ConDecl GhcPs -> HsDeriving GhcPs -> TyClDecl GhcPs -mkNewtype name {- tbinds -} cdecl deriv = +mkNewtype name tbinds cdecl deriv = DataDecl (mkRelEpAnn (-1) annos) (mkLIdP 0 name) qty Prefix dfn where annos = [ AddEpAnn AnnNewtype (mkEpaDelta (-1)), AddEpAnn AnnEqual (mkEpaDelta 0) ] - qty = HsQTvs noExtField [] + qty = HsQTvs noExtField $ fmap (mkL 0) tbinds dfn = HsDataDefn { dd_ext = noExtField, @@ -789,8 +792,22 @@ mkBind1_ :: HsBind GhcPs mkBind1_ fname pats rhs = mkBind1 fname pats rhs (EmptyLocalBinds noExtField) +listSep :: (EpaLocation -> TrailingAnn) -> [a] -> [GenLocated SrcSpanAnnA a] +listSep _ [] = [] +listSep _ (x : []) = [mkL (-1) x] +listSep sep xs = + let xs' = init xs + lastX = last xs + xs'' = + fmap + (L (mkRelSrcSpanAnn 0 (AnnListItem [sep (mkEpaDelta (-1))]))) + xs' + in (xs'' ++ [mkL 0 lastX]) + tupleAnn :: [a] -> [GenLocated SrcSpanAnnA a] -tupleAnn [] = [] +tupleAnn = listSep AddCommaAnn + +{- tupleAnn [] = [] tupleAnn (x : []) = [mkL (-1) x] tupleAnn xs = let xs' = init xs @@ -800,6 +817,7 @@ tupleAnn xs = (L (mkRelSrcSpanAnn 0 (AnnListItem [AddCommaAnn (mkEpaDelta (-1))]))) xs' in (xs'' ++ [mkL 0 lastX]) +-} -- -- Typeclass @@ -977,6 +995,9 @@ parP p = (mkL (-1) p) (L (tokLoc (-1)) HsTok) +wildcard :: Pat GhcPs +wildcard = WildPat noExtField + -- -- Expr -- @@ -988,6 +1009,28 @@ app x y = lx = mkL (-1) x ly = mkL 0 y +caseE :: HsExpr GhcPs -> [(Pat GhcPs, HsExpr GhcPs)] -> HsExpr GhcPs +caseE expr matches = + HsCase (mkRelEpAnn (-1) ann) (mkL 0 expr) grp + where + ann = + EpAnnHsCase + { hsCaseAnnCase = mkEpaDelta (-1), + hsCaseAnnOf = mkEpaDelta 0, + hsCaseAnnsRest = [] + } + grp = MG FromSource (L (mkRelSrcSpanAnn (-1) ann') matches') + ann' = + AnnList + Nothing + (Just (AddEpAnn AnnOpenC (mkEpaDelta (-1)))) + (Just (AddEpAnn AnnCloseC (mkEpaDelta (-1)))) + [] + [] + matches' = + listSep AddSemiAnn $ + fmap (\(p, e) -> mkMatch CaseAlt [p] e (EmptyLocalBinds noExtField)) matches + -- NOTE: in ghc API, no difference between constructor and variable con :: String -> HsExpr GhcPs con = mkVar @@ -1056,6 +1099,7 @@ mkMatch mctxt pats rhs bnds = glrhs = let ann = case mctxt of LambdaExpr -> AnnRarrow + CaseAlt -> AnnRarrow _ -> AnnEqual ann' = mkRelEpAnn @@ -1074,7 +1118,7 @@ lamE pats expr = Nothing (Just (AddEpAnn AnnOpenP (mkEpaDelta (-1)))) (Just (AddEpAnn AnnCloseP (mkEpaDelta (-1)))) - [] -- [AddEpAnn AnnLam (mkEpaDelta (-1))] + [] [] match = mkMatch LambdaExpr pats expr (EmptyLocalBinds noExtField) @@ -1098,7 +1142,7 @@ listE itms = (Just (AddEpAnn AnnCloseS (mkEpaDelta (-1)))) [] [] - litms = fmap (mkL (-1)) itms + litms = tupleAnn itms in ExplicitList (mkRelEpAnn (-1) ann) litms where @@ -1340,16 +1384,6 @@ app = LHE.app app' :: String -> String -> Exp () app' x y = App () (mkVar x) (mkVar y) -unqual :: String -> QName () -unqual = UnQual () . Ident () - -qualConDecl :: - Maybe [TyVarBind ()] -> - Maybe (Context ()) -> - ConDecl () -> - QualConDecl () -qualConDecl = QualConDecl () - recDecl :: String -> [FieldDecl ()] -> ConDecl () recDecl n rs = RecDecl () (Ident () n) rs @@ -1383,9 +1417,6 @@ x `dot` y = x `app` mkVar "." `app` y tyForeignPtr :: Type () tyForeignPtr = tycon "ForeignPtr" -typeBracket :: Type () -> Bracket () -typeBracket = TypeBracket () - evar :: QName () -> ExportSpec () evar = EVar () @@ -1408,25 +1439,12 @@ emodule nm = EModuleContents () (ModuleName () nm) nonamespace :: Namespace () nonamespace = NoNamespace () -generator :: Pat () -> Exp () -> Stmt () -generator = Generator () - -qualifier :: Exp () -> Stmt () -qualifier = Qualifier () - -unkindedVar :: Name () -> TyVarBind () -unkindedVar = UnkindedVar () - if_ :: Exp () -> Exp () -> Exp () -> Exp () if_ = If () urhs :: Exp () -> Rhs () urhs = UnGuardedRhs () --- | case pattern match p -> e -match :: Pat () -> Exp () -> Alt () -match p e = Alt () p (urhs e) Nothing - eWildCard :: Int -> EWildcard () eWildCard = EWildcard () -} From f27d27bf1e2e34685bf616bec65360f32555bda4 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Sat, 12 Aug 2023 12:10:11 -0700 Subject: [PATCH 11/19] Finally no more haskell-src-exts! (#221) * genImportInModule implemented. * ethingall, evar, eabs * top-level exports * upgrade all imports * genTopLevelDef. remove old code. * genTLTemplateInterface * genTLTemplateImplementation * Finally! it fully worked with the migrated functions. * remove haskell-src-exts! * ormolu format --- fficxx/fficxx.cabal | 2 - fficxx/src/FFICXX/Generate/Builder.hs | 13 +- fficxx/src/FFICXX/Generate/Code/HsFFI.hs | 17 - fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs | 233 ++++----- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 320 +------------ fficxx/src/FFICXX/Generate/ContentMaker.hs | 127 ++--- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 320 ++++--------- .../FFICXX/Generate/Util/HaskellSrcExts.hs | 452 ------------------ 8 files changed, 274 insertions(+), 1210 deletions(-) delete mode 100644 fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 581870c4..ccec9daf 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -41,7 +41,6 @@ Library , template-haskell , text , unordered-containers - , haskell-src-exts if impl (ghc >= 9.6) Build-Depends: ghc >= 9.6, @@ -75,7 +74,6 @@ Library FFICXX.Generate.Util FFICXX.Generate.Util.DepGraph FFICXX.Generate.Util.GHCExactPrint - FFICXX.Generate.Util.HaskellSrcExts FFICXX.Generate.Type.Annotate FFICXX.Generate.Type.Cabal FFICXX.Generate.Type.Config diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 8a24cd27..05033f09 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -43,7 +43,6 @@ import FFICXX.Generate.Type.Module ) import FFICXX.Generate.Util (moduleDirFile) import FFICXX.Generate.Util.GHCExactPrint (exactPrint) -import FFICXX.Generate.Util.HaskellSrcExts (prettyPrint) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified Language.Haskell.GHC.ExactPrint as Exact import System.Directory @@ -220,25 +219,27 @@ simpleBuilder cfg sbc = do for_ mods $ \m -> gen (cmModule m <.> "hs") - (prettyPrint (C.buildModuleHs m)) + (exactPrint (C.buildModuleHs m)) -- putStrLn "Generating Top-level Ordinary Module" - gen (topLevelMod <.> "Ordinary" <.> "hs") (prettyPrint (C.buildTopLevelOrdinaryHs (topLevelMod <> ".Ordinary") (mods, tcms) tih)) + gen + (topLevelMod <.> "Ordinary" <.> "hs") + (postProcess $ exactPrint (C.buildTopLevelOrdinaryHs (topLevelMod <> ".Ordinary") (mods, tcms) tih)) -- putStrLn "Generating Top-level Template Module" gen (topLevelMod <.> "Template" <.> "hs") - (prettyPrint (C.buildTopLevelTemplateHs (topLevelMod <> ".Template") tih)) + (exactPrint (C.buildTopLevelTemplateHs (topLevelMod <> ".Template") tih)) -- putStrLn "Generating Top-level TH Module" gen (topLevelMod <.> "TH" <.> "hs") - (prettyPrint (C.buildTopLevelTHHs (topLevelMod <> ".TH") tih)) + (exactPrint (C.buildTopLevelTHHs (topLevelMod <> ".TH") tih)) -- putStrLn "Generating Top-level Module" gen (topLevelMod <.> "hs") - (prettyPrint (C.buildTopLevelHs topLevelMod (mods, tcms))) + (exactPrint (C.buildTopLevelHs topLevelMod (mods, tcms))) -- putStrLn "Copying generated files to target directory" touch (workingDir "LICENSE") diff --git a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs index f327590f..c27de5df 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs @@ -11,8 +11,6 @@ import FFICXX.Generate.Code.Primitive genericFuncRet, hsFFIFunType, ) --- -import qualified FFICXX.Generate.Code.Primitive as O (hsFFIFuncTyp) import FFICXX.Generate.Dependency ( class_allparents, ) @@ -46,12 +44,10 @@ import FFICXX.Generate.Util.GHCExactPrint ( mkForImpCcall, mkImport, ) -import qualified FFICXX.Generate.Util.HaskellSrcExts as O import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import GHC.Hs ( GhcPs, ) -import qualified Language.Haskell.Exts.Syntax as O import Language.Haskell.Syntax ( ForeignDecl, ImportDecl, @@ -122,16 +118,3 @@ genTopLevelFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) c -- TODO: This must be exposed as a top-level function cfname = "c_" <> toLowers fname typ = hsFFIFunType Nothing (CFunSig args ret) - --- TODO: Remove -genTopLevelFFI_ :: TopLevelImportHeader -> TLOrdinary -> O.Decl () -genTopLevelFFI_ header tfn = O.mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ - where - (fname, args, ret) = - case tfn of - TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret) - TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret) - hfilename = tihHeaderFileName header <.> "h" - -- TODO: This must be exposed as a top-level function - cfname = "c_" <> toLowers fname - typ = O.hsFFIFuncTyp Nothing (CFunSig args ret) diff --git a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs index f3b8df1a..c4254d63 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs @@ -31,8 +31,8 @@ import FFICXX.Generate.Code.Cpp import FFICXX.Generate.Code.Primitive ( CFunSig (..), HsFunSig (..), - convertCpp2HS, - convertCpp2HS4Tmpl, + cxx2HsType, + cxx2HsType4Tmpl, extractArgRetTypes, ) import FFICXX.Generate.Dependency @@ -49,14 +49,6 @@ import FFICXX.Generate.Name hsFrontNameForTopLevel, typeclassName, ) -{- import FFICXX.Generate.Type.Class - ( Class (..), - TemplateClass (..), - TemplateFunction (..), - TemplateMemberFunction (..), - Types (Void), - Variable (..), - ) -} import FFICXX.Generate.Type.Class ( Arg (..), Class (..), @@ -76,34 +68,46 @@ import FFICXX.Generate.Type.Module ) import FFICXX.Generate.Util (firstUpper, toLowers) -- -import FFICXX.Generate.Util.HaskellSrcExts - ( bracketExp, - clsDecl, +import FFICXX.Generate.Util.GHCExactPrint + ( app, + bracketExp, + caseE, con, cxEmpty, cxTuple, + doE, eabs, + emodule, ethingall, evar, - generator, inapp, + lamE, + letE, listE, - match, mkBind1, + mkBind1_, + mkBindStmt, + mkBodyStmt, mkClass, mkFun, mkFunSig, + mkFun_, mkImport, + mkLetStmt, mkPVar, mkTBind, mkVar, - nonamespace, op, + pTuple, + par, parenSplice, pbind_, - qualifier, + qualTy, strE, + toLocalBinds, + tupleE, tyForall, + tyParen, tySplice, tyTupleBoxed, tyapp, @@ -112,28 +116,18 @@ import FFICXX.Generate.Util.HaskellSrcExts tylist, typeBracket, unqual, + valBinds, + wildcard, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) -import Language.Haskell.Exts.Build - ( app, - binds, - caseE, - doE, - lamE, - letE, - letStmt, - pTuple, - paren, - qualStmt, - tuple, - wildcard, - ) -import Language.Haskell.Exts.Syntax - ( Decl, - ExportSpec, +import GHC.Hs (GhcPs) +import Language.Haskell.Syntax + ( HsDecl (TyClD), + IE, ImportDecl, + noExtField, ) import System.FilePath ((<.>)) @@ -145,26 +139,26 @@ import System.FilePath ((<.>)) -- Export -- ------------ -genExport :: Class -> [ExportSpec ()] +genExport :: Class -> [IE GhcPs] genExport c = let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) - then eabs nonamespace (unqual n) - else ethingall (unqual n) + then eabs n + else ethingall n in if isAbstractClass c then [espec (typeclassName c)] else - [ ethingall (unqual ((fst . hsClassName) c)), + [ ethingall ((fst . hsClassName) c), espec (typeclassName c), - evar (unqual ("upcast" <> (fst . hsClassName) c)), - evar (unqual ("downcast" <> (fst . hsClassName) c)) + evar ("upcast" <> (fst . hsClassName) c), + evar ("downcast" <> (fst . hsClassName) c) ] <> genExportConstructorAndNonvirtual c <> genExportStatic c -- | constructor and non-virtual function -genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()] -genExportConstructorAndNonvirtual c = map (evar . unqual) fns +genExportConstructorAndNonvirtual :: Class -> [IE GhcPs] +genExportConstructorAndNonvirtual c = fmap evar fns where fs = class_funcs c fns = @@ -175,8 +169,8 @@ genExportConstructorAndNonvirtual c = map (evar . unqual) fns ) -- | staic function export list -genExportStatic :: Class -> [ExportSpec ()] -genExportStatic c = map (evar . unqual) fns +genExportStatic :: Class -> [IE GhcPs] +genExportStatic c = fmap evar fns where fs = class_funcs c fns = map (aliasedFuncName c) (staticFuncs fs) @@ -186,14 +180,14 @@ genExportStatic c = map (evar . unqual) fns -- -- | module summary re-exports -genImportInModule :: Class -> [ImportDecl ()] +genImportInModule :: Class -> [ImportDecl GhcPs] genImportInModule x = map (\y -> mkImport (getClassModuleBase x <.> y)) ["RawType", "Interface", "Implementation"] -- | top=level genImportInTopLevel :: String -> ([ClassModule], [TemplateClassModule]) -> - [ImportDecl ()] + [ImportDecl GhcPs] genImportInTopLevel modname (mods, _tmods) = map (mkImport . cmModule) mods ++ map mkImport [modname <.> "Template", modname <.> "TH", modname <.> "Ordinary"] @@ -202,7 +196,7 @@ genImportInTopLevel modname (mods, _tmods) = -- declarations and definitions -- -genTopLevelDef :: TLOrdinary -> [Decl ()] +genTopLevelDef :: TLOrdinary -> [HsDecl GhcPs] genTopLevelDef f@TopLevelFunction {..} = let fname = hsFrontNameForTopLevel (TLOrdinary f) HsFunSig typs assts = @@ -210,24 +204,24 @@ genTopLevelDef f@TopLevelFunction {..} = Nothing False (CFunSig toplevelfunc_args toplevelfunc_ret) - sig = tyForall Nothing (Just (cxTuple assts)) (foldr1 tyfun typs) + sig = qualTy (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 + in mkFun_ fname sig [] rhs genTopLevelDef v@TopLevelVariable {..} = let fname = hsFrontNameForTopLevel (TLOrdinary v) cfname = "c_" <> toLowers fname - rtyp = convertCpp2HS Nothing toplevelvar_ret - sig = tyapp (tycon "IO") rtyp + rtyp = cxx2HsType Nothing toplevelvar_ret + sig = tyapp (tycon "IO") (tyParen rtyp) rhs = app (mkVar "xformnull") (mkVar cfname) - in mkFun fname sig [] rhs Nothing + in mkFun_ fname sig [] rhs -- | generate import list for a given top-level ordinary function -- currently this may generate duplicate import list. -- TODO: eliminate duplicated imports. -- TODO2: should be refactored out. -genImportForTLOrdinary :: TLOrdinary -> [ImportDecl ()] +genImportForTLOrdinary :: TLOrdinary -> [ImportDecl GhcPs] genImportForTLOrdinary f = let dep4func = extractClassDepForTLOrdinary f ecs = returnDependency dep4func ++ argumentDependency dep4func @@ -240,7 +234,7 @@ genImportForTLOrdinary f = -- currently this may generate duplicate import list. -- TODO: eliminate duplicated imports. -- TODO2: should be refactored out. -genImportForTLTemplate :: TLTemplate -> [ImportDecl ()] +genImportForTLTemplate :: TLTemplate -> [ImportDecl GhcPs] genImportForTLTemplate f = let dep4func = extractClassDepForTLTemplate f ecs = returnDependency dep4func ++ argumentDependency dep4func @@ -253,20 +247,21 @@ genImportForTLTemplate f = -- top-level template -- -genTLTemplateInterface :: TLTemplate -> [Decl ()] +genTLTemplateInterface :: TLTemplate -> [HsDecl GhcPs] genTLTemplateInterface t = - [ mkClass cxEmpty (firstUpper (topleveltfunc_name t)) (map mkTBind tps) methods + [ TyClD noExtField $ + mkClass cxEmpty (firstUpper (topleveltfunc_name t)) (map mkTBind tps) methods ] where tps = topleveltfunc_params t - ctyp = convertCpp2HS Nothing (topleveltfunc_ret t) - lst = map (convertCpp2HS Nothing . arg_type) (topleveltfunc_args t) - sigdecl = mkFunSig (topleveltfunc_name t) $ foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) - methods = [clsDecl sigdecl] + ctyp = cxx2HsType Nothing (topleveltfunc_ret t) + lst = map (cxx2HsType Nothing . arg_type) (topleveltfunc_args t) + sigdecl = mkFunSig (topleveltfunc_name t) $ foldr1 tyfun (lst <> [tyapp (tycon "IO") (tyParen ctyp)]) + methods = [sigdecl] -genTLTemplateImplementation :: TLTemplate -> [Decl ()] +genTLTemplateImplementation :: TLTemplate -> [HsDecl GhcPs] genTLTemplateImplementation t = - mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + mkFun nh sig (tvars_p ++ [p "suffix"]) rhs bstmts where v = mkVar p = mkPVar @@ -283,38 +278,40 @@ genTLTemplateImplementation t = lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") rhs = app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] - in tuple (typs ++ [v "suffix", lam, v "tyf"]) + let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = let e = error "genTLTemplateImplementation" spls = map (tySplice . parenSplice . mkVar) $ topleveltfunc_params t - ctyp = convertCpp2HS4Tmpl e Nothing spls (topleveltfunc_ret t) - lst = map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (topleveltfunc_args t) - in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) - tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps + ctyp = cxx2HsType4Tmpl e Nothing spls (topleveltfunc_ret t) + lst = map (cxx2HsType4Tmpl e Nothing spls . arg_type) (topleveltfunc_args t) + in foldr1 tyfun (lst <> [tyapp (tycon "IO") (tyParen ctyp)]) + tassgns = + fmap + (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) + itps bstmts = - binds - [ mkBind1 - "tyf" - [wildcard] - ( letE - tassgns - (bracketExp (typeBracket sig')) - ) - Nothing - ] + toLocalBinds True $ + valBinds + [ mkBind1_ + "tyf" + [wildcard] + ( letE + (toLocalBinds False (valBinds tassgns)) + (bracketExp (typeBracket sig')) + ) + ] genTLTemplateInstance :: TopLevelImportHeader -> TLTemplate -> - [Decl ()] + [HsDecl GhcPs] genTLTemplateInstance tih t = - mkFun + mkFun_ fname sig (p "isCprim" : zipWith (\x y -> pTuple [p x, p y]) qtvars pvars) rhs - Nothing where p = mkPVar v = mkVar @@ -325,7 +322,7 @@ genTLTemplateInstance tih t = qtvars = map (\(i, _) -> "qtyp" ++ show i) itps pvars = map (\(i, _) -> "param" ++ show i) itps nparams = length itps - typs_v = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars) + typs_v = if nparams == 1 then v (tvars !! 0) else tupleE (map v tvars) params_l = listE (map v pvars) sig = foldr1 tyfun $ @@ -342,8 +339,8 @@ genTLTemplateInstance tih t = rhs = doE ( [paramsstmt, suffixstmt] - <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), - letStmt + <> [ mkBindStmt (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")), + mkLetStmt [ pbind_ (p "callmod") (v "dot2_" `app` v "callmod_") @@ -352,19 +349,19 @@ genTLTemplateInstance tih t = <> map genqtypstmt (zip tvars qtvars) <> [genstmt "f" (1 :: Int)] <> [ foreignSrcStmt, - letStmt lststmt, - qualStmt retstmt + mkLetStmt lststmt, + mkBodyStmt retstmt ] ) -------------------------- paramsstmt = - letStmt + mkLetStmt [ pbind_ (p "params") (v "map" `app` (v "tpinfoSuffix") `app` params_l) ] suffixstmt = - letStmt + mkLetStmt [ pbind_ (p "suffix") ( v "concatMap" @@ -372,9 +369,9 @@ genTLTemplateInstance tih t = `app` params_l ) ] - genqtypstmt (tvar, qtvar) = generator (p tvar) (v qtvar) + genqtypstmt (tvar, qtvar) = mkBindStmt (p tvar) (v qtvar) genstmt prefix n = - generator + mkBindStmt (p (prefix <> show n)) ( v "mkFunc" `app` strE (topleveltfunc_name t) @@ -385,30 +382,32 @@ genTLTemplateInstance tih t = lststmt = [pbind_ (p "lst") (listE [v "f1"])] -- TODO: refactor out the following code. foreignSrcStmt = - qualifier $ + mkBodyStmt $ (v "addModFinalizer") - `app` ( v "addForeignSource" - `app` con "LangCxx" - `app` ( L.foldr1 - (\x y -> inapp x (op "++") y) - [ includeStatic, - {- , includeDynamic - , namespaceStr -} - strE (tcname <> "_instance"), - paren $ - caseE - (v "isCprim") - [ match (p "CPrim") (strE "_s"), - match (p "NonCPrim") (strE "") - ], - strE "(", - v "intercalate" - `app` strE ", " - `app` paren (inapp (v "callmod") (op ":") (v "params")), - strE ")\n" - ] - ) - ) + `app` par + ( v "addForeignSource" + `app` con "LangCxx" + `app` par + ( L.foldr1 + (\x y -> inapp x (op "++") y) + [ includeStatic, + {- , includeDynamic + , namespaceStr -} + strE (tcname <> "_instance"), + par $ + caseE + (v "isCprim") + [ (p "CPrim", strE "_s"), + (p "NonCPrim", strE "") + ], + strE "(", + v "intercalate" + `app` strE ", " + `app` par (inapp (v "callmod") (op ":") (v "params")), + strE ")\n" + ] + ) + ) where -- temporary includeStatic = @@ -450,8 +449,10 @@ genTLTemplateInstance tih t = [ v "mkInstance" `app` listE [] -- `app` (v "con" `app` strE tcname) - `app` foldl1 - (\f x -> con "AppT" `app` f `app` x) - (v "con" `app` strE tcname : map v tvars) + `app` par + ( foldl1 + (\f x -> con "AppT" `app` f `app` x) + (par (v "con" `app` strE tcname) : map v tvars) + ) `app` (v "lst") ] diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 6fa153a8..e2e77115 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -36,28 +36,9 @@ import FFICXX.Generate.Type.Class isVirtualFunc, ) import qualified FFICXX.Generate.Util.GHCExactPrint as Ex -import FFICXX.Generate.Util.HaskellSrcExts - ( classA, - cxTuple, - mkTVar, - mkVar, - parenSplice, - tyForall, - tyPtr, - tySplice, - tyapp, - tycon, - tyfun, - unit_tycon, - unqual, - ) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) import GHC.Hs (GhcPs) -import Language.Haskell.Exts.Syntax - ( Asst, - Type, - ) import Language.Haskell.Syntax ( HsContext, HsType, @@ -68,16 +49,9 @@ data CFunSig = CFunSig cRetType :: Types } --- | OLD data HsFunSig = HsFunSig - { hsSigTypes :: [Type ()], - hsSigConstraints :: [Asst ()] - } - --- | NEW -data HsFunSig' = HsFunSig' - { hsSig'Types :: [HsType GhcPs], - hsSig'Constraints :: [HsType GhcPs] + { hsSigTypes :: [HsType GhcPs], + hsSigConstraints :: [HsType GhcPs] } ctypToCType :: CTypes -> IsConst -> R.CType Identity @@ -689,50 +663,6 @@ tmplMemFuncReturnCType _ (TemplateType _) = R.CTStar R.CTVoid tmplMemFuncReturnCType _ (TemplateParam t) = R.CTSimple $ R.CName [R.NamePart t, R.NamePart "_p"] tmplMemFuncReturnCType _ (TemplateParamPointer t) = R.CTSimple $ R.CName [R.NamePart t, R.NamePart "_p"] -convertC2HS :: CTypes -> Type () -convertC2HS CTBool = tycon "CBool" -convertC2HS CTChar = tycon "CChar" -convertC2HS CTClock = tycon "CClock" -convertC2HS CTDouble = tycon "CDouble" -convertC2HS CTFile = tycon "CFile" -convertC2HS CTFloat = tycon "CFloat" -convertC2HS CTFpos = tycon "CFpos" -convertC2HS CTInt = tycon "CInt" -convertC2HS CTIntMax = tycon "CIntMax" -convertC2HS CTIntPtr = tycon "CIntPtr" -convertC2HS CTJmpBuf = tycon "CJmpBuf" -convertC2HS CTLLong = tycon "CLLong" -convertC2HS CTLong = tycon "CLong" -convertC2HS CTPtrdiff = tycon "CPtrdiff" -convertC2HS CTSChar = tycon "CSChar" -convertC2HS CTSUSeconds = tycon "CSUSeconds" -convertC2HS CTShort = tycon "CShort" -convertC2HS CTSigAtomic = tycon "CSigAtomic" -convertC2HS CTSize = tycon "CSize" -convertC2HS CTTime = tycon "CTime" -convertC2HS CTUChar = tycon "CUChar" -convertC2HS CTUInt = tycon "CUInt" -convertC2HS CTUIntMax = tycon "CUIntMax" -convertC2HS CTUIntPtr = tycon "CUIntPtr" -convertC2HS CTULLong = tycon "CULLong" -convertC2HS CTULong = tycon "CULong" -convertC2HS CTUSeconds = tycon "CUSeconds" -convertC2HS CTUShort = tycon "CUShort" -convertC2HS CTWchar = tycon "CWchar" -convertC2HS CTInt8 = tycon "Int8" -convertC2HS CTInt16 = tycon "Int16" -convertC2HS CTInt32 = tycon "Int32" -convertC2HS CTInt64 = tycon "Int64" -convertC2HS CTUInt8 = tycon "Word8" -convertC2HS CTUInt16 = tycon "Word16" -convertC2HS CTUInt32 = tycon "Word32" -convertC2HS CTUInt64 = tycon "Word64" -convertC2HS CTString = tycon "CString" -convertC2HS CTVoidStar = tyapp (tycon "Ptr") unit_tycon -convertC2HS (CEnum t _) = convertC2HS t -convertC2HS (CPointer t) = tyapp (tycon "Ptr") (convertC2HS t) -convertC2HS (CRef t) = tyapp (tycon "Ptr") (convertC2HS t) - -- new c2HsType :: CTypes -> HsType GhcPs c2HsType CTBool = Ex.tycon "CBool" @@ -778,35 +708,6 @@ c2HsType (CEnum t _) = c2HsType t c2HsType (CPointer t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) c2HsType (CRef t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) --- OLD -convertCpp2HS :: Maybe Class -> Types -> Type () -convertCpp2HS _c Void = unit_tycon -convertCpp2HS (Just c) SelfType = tycon ((fst . hsClassName) c) -convertCpp2HS Nothing SelfType = error "convertCpp2HS : SelfType but no class " -convertCpp2HS _c (CT t _) = convertC2HS t -convertCpp2HS _c (CPT (CPTClass c') _) = (tycon . fst . hsClassName) c' -convertCpp2HS _c (CPT (CPTClassRef c') _) = (tycon . fst . hsClassName) c' -convertCpp2HS _c (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c' -convertCpp2HS _c (CPT (CPTClassMove c') _) = (tycon . fst . hsClassName) c' -convertCpp2HS _c (TemplateApp x) = - foldl1 tyapp $ - map tycon $ - tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) -convertCpp2HS _c (TemplateAppRef x) = - foldl1 tyapp $ - map tycon $ - tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) -convertCpp2HS _c (TemplateAppMove x) = - foldl1 tyapp $ - map tycon $ - tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) -convertCpp2HS _c (TemplateType t) = - foldl1 tyapp $ - tycon (tclass_name t) : map mkTVar (tclass_params t) -convertCpp2HS _c (TemplateParam p) = mkTVar p -convertCpp2HS _c (TemplateParamPointer p) = mkTVar p - --- NEW cxx2HsType :: Maybe Class -> Types -> HsType GhcPs cxx2HsType _c Void = Ex.unit_tycon cxx2HsType (Just c) SelfType = Ex.tycon ((fst . hsClassName) c) @@ -834,40 +735,6 @@ cxx2HsType _c (TemplateType t) = cxx2HsType _c (TemplateParam p) = Ex.mkTVar p cxx2HsType _c (TemplateParamPointer p) = Ex.mkTVar p --- OLD -convertCpp2HS4Tmpl :: - -- | self - Type () -> - Maybe Class -> - -- | type paramemter splice - [Type ()] -> - Types -> - Type () -convertCpp2HS4Tmpl _ c _ Void = convertCpp2HS c Void -convertCpp2HS4Tmpl _ (Just c) _ SelfType = convertCpp2HS (Just c) SelfType -convertCpp2HS4Tmpl _ Nothing _ SelfType = convertCpp2HS Nothing SelfType -convertCpp2HS4Tmpl _ c _ x@(CT _ _) = convertCpp2HS c x -convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClass _) _) = convertCpp2HS c x -convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassRef _) _) = convertCpp2HS c x -convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassCopy _) _) = convertCpp2HS c x -convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassMove _) _) = convertCpp2HS c x -convertCpp2HS4Tmpl _ _ ss (TemplateApp info) = - let pss = zip (tapp_tparams info) ss - in foldl1 tyapp $ - tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _, s) -> s; (p, _) -> tycon (hsClassNameForTArg p)) pss -convertCpp2HS4Tmpl _ _ ss (TemplateAppRef info) = - let pss = zip (tapp_tparams info) ss - in foldl1 tyapp $ - tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _, s) -> s; (p, _) -> tycon (hsClassNameForTArg p)) pss -convertCpp2HS4Tmpl _ _ ss (TemplateAppMove info) = - let pss = zip (tapp_tparams info) ss - in foldl1 tyapp $ - tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _, s) -> s; (p, _) -> tycon (hsClassNameForTArg p)) pss -convertCpp2HS4Tmpl e _ _ (TemplateType _) = e -convertCpp2HS4Tmpl _ _ _ (TemplateParam p) = tySplice . parenSplice . mkVar $ p -convertCpp2HS4Tmpl _ _ _ (TemplateParamPointer p) = tySplice . parenSplice . mkVar $ p - --- NEW cxx2HsType4Tmpl :: -- | self HsType GhcPs -> @@ -919,73 +786,7 @@ classConstraints :: Class -> HsContext GhcPs classConstraints = Ex.cxTuple . map ((\name -> Ex.classA name [Ex.mkTVar "a"]) . typeclassName) . class_parents --- OLD extractArgRetTypes :: - -- | class (Nothing for top-level function) - Maybe Class -> - -- | is virtual function? - Bool -> - -- | C type signature information for a given function -- (Args,Types) -- ^ (argument types, return type) of a given function - CFunSig -> - -- | Haskell type signature information for the function -- ([Type ()],[Asst ()]) -- ^ (types, class constraints) - HsFunSig -extractArgRetTypes mc isvirtual (CFunSig args ret) = - let (typs, s) = flip runState ([], (0 :: Int)) $ do - as <- mapM (mktyp . arg_type) args - r <- case ret of - SelfType -> case mc of - Nothing -> error "extractArgRetTypes: SelfType return but no class" - Just c -> if isvirtual then return (mkTVar "a") else return $ tycon ((fst . hsClassName) c) - x -> (return . convertCpp2HS Nothing) x - return (as ++ [tyapp (tycon "IO") r]) - in HsFunSig - { hsSigTypes = typs, - hsSigConstraints = fst s - } - where - addclass c = do - (ctxts, n) <- get - let cname = (fst . hsClassName) c - iname = typeclassNameFromStr cname - tvar = mkTVar ('c' : show n) - ctxt1 = classA (unqual iname) [tvar] - ctxt2 = classA (unqual "FPtr") [tvar] - put (ctxt1 : ctxt2 : ctxts, n + 1) - return tvar - addstring = do - (ctxts, n) <- get - let tvar = mkTVar ('c' : show n) - ctxt = classA (unqual "Castable") [tvar, tycon "CString"] - put (ctxt : ctxts, n + 1) - return tvar - mktyp typ = - case typ of - SelfType -> return (mkTVar "a") - CT CTString Const -> addstring - CT _ _ -> return $ convertCpp2HS Nothing typ - CPT (CPTClass c') _ -> addclass c' - CPT (CPTClassRef c') _ -> addclass c' - CPT (CPTClassCopy c') _ -> addclass c' - CPT (CPTClassMove c') _ -> addclass c' - -- it is not clear whether the following is okay or not. - (TemplateApp x) -> - pure $ - convertCpp2HS Nothing (TemplateApp x) - (TemplateAppRef x) -> - pure $ - convertCpp2HS Nothing (TemplateAppRef x) - (TemplateAppMove x) -> - pure $ - convertCpp2HS Nothing (TemplateAppMove x) - (TemplateType t) -> - pure $ - foldl1 tyapp (tycon (tclass_name t) : map mkTVar (tclass_params t)) - (TemplateParam p) -> return (mkTVar p) - Void -> return unit_tycon - _ -> error ("No such c type : " <> show typ) - --- NEW -extractArgRetTypes' :: -- | class (Nothing for top-level function) Maybe Class -> -- | is virtual function? @@ -995,8 +796,8 @@ extractArgRetTypes' :: CFunSig -> -- | Haskell type signature information for the function: -- (types, class constraints) - HsFunSig' -extractArgRetTypes' mc isvirtual (CFunSig args ret) = + HsFunSig +extractArgRetTypes mc isvirtual (CFunSig args ret) = let (typs, s) = flip runState ([], (0 :: Int)) $ do as <- mapM (mktyp . arg_type) args r <- case ret of @@ -1008,9 +809,9 @@ extractArgRetTypes' mc isvirtual (CFunSig args ret) = else return $ Ex.tycon ((fst . hsClassName) c) x -> (return . cxx2HsType Nothing) x return (as ++ [Ex.tyapp (Ex.tycon "IO") r]) - in HsFunSig' - { hsSig'Types = typs, - hsSig'Constraints = fst s + in HsFunSig + { hsSigTypes = typs, + hsSigConstraints = fst s } where addclass c = do @@ -1056,8 +857,8 @@ extractArgRetTypes' mc isvirtual (CFunSig args ret) = functionSignature :: Class -> Function -> HsType GhcPs functionSignature c f = - let HsFunSig' typs assts = - extractArgRetTypes' + let HsFunSig typs assts = + extractArgRetTypes (Just c) (isVirtualFunc f) (CFunSig (genericFuncArgs f) (genericFuncRet f)) @@ -1144,112 +945,11 @@ accessorCFunSig typ Setter = CFunSig [Arg typ "x"] Void accessorSignature :: Class -> Variable -> Accessor -> HsType GhcPs accessorSignature c v accessor = let csig = accessorCFunSig (arg_type (unVariable v)) accessor - HsFunSig' typs assts = extractArgRetTypes' (Just c) False csig + HsFunSig typs assts = extractArgRetTypes (Just c) False csig ctxt = Ex.cxTuple assts arg0 = (Ex.mkTVar (fst (hsClassName c)) :) in Ex.qualTy ctxt (foldr1 Ex.tyfun (arg0 typs)) --- | old function. this is for FFI type. -hsFFIFuncTyp :: Maybe (Selfness, Class) -> CFunSig -> Type () -hsFFIFuncTyp msc (CFunSig args ret) = - foldr1 tyfun $ case msc of - Nothing -> argtyps <> [tyapp (tycon "IO") rettyp] - Just (Self, _) -> selftyp : argtyps <> [tyapp (tycon "IO") rettyp] - Just (NoSelf, _) -> argtyps <> [tyapp (tycon "IO") rettyp] - where - argtyps :: [Type ()] - argtyps = map (hsargtype . arg_type) args - rettyp :: Type () - rettyp = hsrettype ret - selftyp = case msc of - Just (_, c) -> tyapp tyPtr (tycon (snd (hsClassName c))) - Nothing -> error "hsFFIFuncTyp: no self for top level function" - hsargtype :: Types -> Type () - hsargtype (CT ctype _) = convertC2HS ctype - hsargtype (CPT (CPTClass d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsargtype (CPT (CPTClassRef d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsargtype (CPT (CPTClassMove d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsargtype (CPT (CPTClassCopy d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsargtype (TemplateApp x) = - tyapp tyPtr $ - foldl1 tyapp $ - map tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsargtype (TemplateAppRef x) = - tyapp tyPtr $ - foldl1 tyapp $ - map tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsargtype (TemplateAppMove x) = - tyapp tyPtr $ - foldl1 tyapp $ - map tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsargtype (TemplateType t) = tyapp tyPtr $ foldl1 tyapp (tycon rawname : map mkTVar (tclass_params t)) - where - rawname = snd (hsTemplateClassName t) - hsargtype (TemplateParam p) = mkTVar p - hsargtype SelfType = selftyp - hsargtype _ = error "hsFuncTyp: undefined hsargtype" - --------------------------------------------------------- - hsrettype Void = unit_tycon - hsrettype SelfType = selftyp - hsrettype (CT ctype _) = convertC2HS ctype - hsrettype (CPT (CPTClass d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsrettype (CPT (CPTClassRef d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsrettype (CPT (CPTClassCopy d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsrettype (CPT (CPTClassMove d) _) = tyapp tyPtr (tycon rawname) - where - rawname = snd (hsClassName d) - hsrettype (TemplateApp x) = - tyapp tyPtr $ - foldl1 tyapp $ - map tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsrettype (TemplateAppRef x) = - tyapp tyPtr $ - foldl1 tyapp $ - map tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsrettype (TemplateAppMove x) = - tyapp tyPtr $ - foldl1 tyapp $ - map tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsrettype (TemplateType t) = - tyapp tyPtr $ - foldl1 tyapp (tycon rawname : map mkTVar (tclass_params t)) - where - rawname = snd (hsTemplateClassName t) - hsrettype (TemplateParam p) = mkTVar p - hsrettype (TemplateParamPointer p) = mkTVar p - -- | new function hsFFIFunType :: Maybe (Selfness, Class) -> CFunSig -> HsType GhcPs hsFFIFunType msc (CFunSig args ret) = diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 380cc627..0a5d5e3c 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -40,7 +40,7 @@ import FFICXX.Generate.Code.HsCommon import FFICXX.Generate.Code.HsFFI ( genHsFFI, genImportInFFI, - genTopLevelFFI_, + genTopLevelFFI, ) import FFICXX.Generate.Code.HsImplementation ( genHsFrontInst, @@ -115,24 +115,12 @@ import FFICXX.Generate.Type.PackageInterface ) import FFICXX.Generate.Util (firstUpper) import qualified FFICXX.Generate.Util.GHCExactPrint as Ex -import FFICXX.Generate.Util.HaskellSrcExts - ( eWildCard, - emodule, - ethingwith, - evar, - lang, - mkImport, - mkModuleE, - unqual, - ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import GHC.Hs.Extension (GhcPs) -import Language.Haskell.Exts.Syntax (Module) import Language.Haskell.Syntax - ( HsDecl (ForD), + ( HsDecl, HsModule, - noExtField, ) import System.FilePath ((<.>), ()) @@ -355,7 +343,7 @@ buildFFIHsc m = ] <> genImportInFFI m <> genExtraImport m - hscBody = fmap (ForD noExtField) (genHsFFI (cmCIH m)) + hscBody = fmap Ex.forD (genHsFFI (cmCIH m)) buildRawTypeHs :: ClassModule -> HsModule GhcPs buildRawTypeHs m = @@ -582,29 +570,28 @@ buildTHHs m = tmplImpls = genTmplImplementation t tmplInsts = genTmplInstance (tcmTCIH m) -buildModuleHs :: ClassModule -> Module () -buildModuleHs m = mkModuleE (cmModule m) [] (genExport c) (genImportInModule c) [] +buildModuleHs :: ClassModule -> HsModule GhcPs +buildModuleHs m = + Ex.mkModuleE (cmModule m) [] (Just (genExport c)) (genImportInModule c) [] where c = cihClass (cmCIH m) buildTopLevelHs :: String -> ([ClassModule], [TemplateClassModule]) -> - Module () + HsModule GhcPs buildTopLevelHs modname (mods, tmods) = - mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + Ex.mkModuleE modname pkgExtensions (Just pkgExports) pkgImports pkgBody where pkgExtensions = - [ lang - [ "FlexibleContexts", - "FlexibleInstances", - "ForeignFunctionInterface", - "InterruptibleFFI" - ] + [ "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI" ] pkgExports = - map (emodule . cmModule) mods - ++ map emodule [modname <.> "Ordinary", modname <.> "Template", modname <.> "TH"] + map (Ex.emodule . cmModule) mods + ++ map Ex.emodule [modname <.> "Ordinary", modname <.> "Template", modname <.> "TH"] pkgImports = genImportInTopLevel modname (mods, tmods) pkgBody = [] -- map (genTopLevelFFI tih) (filterTLOrdinary tfns) -- ++ concatMap genTopLevelDef (filterTLOrdinary tfns) @@ -613,59 +600,54 @@ buildTopLevelOrdinaryHs :: String -> ([ClassModule], [TemplateClassModule]) -> TopLevelImportHeader -> - Module () + HsModule GhcPs buildTopLevelOrdinaryHs modname (_mods, tmods) tih = - mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + Ex.mkModuleE modname pkgExtensions (Just pkgExports) pkgImports pkgBody where tfns = tihFuncs tih pkgExtensions = - [ lang - [ "FlexibleContexts", - "FlexibleInstances", - "ForeignFunctionInterface", - "InterruptibleFFI" - ] + [ "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI" ] - pkgExports = map (evar . unqual . hsFrontNameForTopLevel . TLOrdinary) (filterTLOrdinary tfns) + pkgExports = fmap (Ex.evar . hsFrontNameForTopLevel . TLOrdinary) (filterTLOrdinary tfns) pkgImports = - map mkImport ["Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast"] - ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods + fmap Ex.mkImport ["Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast"] + ++ fmap (\m -> Ex.mkImport (tcmModule m <.> "Template")) tmods ++ concatMap genImportForTLOrdinary (filterTLOrdinary tfns) pkgBody = - map (genTopLevelFFI_ tih) (filterTLOrdinary tfns) + map (Ex.forD . genTopLevelFFI tih) (filterTLOrdinary tfns) ++ concatMap genTopLevelDef (filterTLOrdinary tfns) buildTopLevelTemplateHs :: String -> TopLevelImportHeader -> - Module () + HsModule GhcPs buildTopLevelTemplateHs modname tih = - mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + Ex.mkModuleE modname pkgExtensions (Just pkgExports) pkgImports pkgBody where tfns = filterTLTemplate (tihFuncs tih) pkgExtensions = - [ lang - [ "EmptyDataDecls", - "FlexibleInstances", - "ForeignFunctionInterface", - "InterruptibleFFI", - "MultiParamTypeClasses", - "TypeFamilies" - ] + [ "EmptyDataDecls", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI", + "MultiParamTypeClasses", + "TypeFamilies" ] pkgExports = map - ( (\n -> ethingwith (eWildCard 1) n []) - . unqual + ( (\n -> Ex.ethingall n) . firstUpper . hsFrontNameForTopLevel . TLTemplate ) tfns pkgImports = - [ mkImport "Foreign.C.Types", - mkImport "Foreign.Ptr", - mkImport "FFICXX.Runtime.Cast" + [ Ex.mkImport "Foreign.C.Types", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport "FFICXX.Runtime.Cast" ] ++ concatMap genImportForTLTemplate tfns pkgBody = concatMap genTLTemplateInterface tfns @@ -673,24 +655,21 @@ buildTopLevelTemplateHs modname tih = buildTopLevelTHHs :: String -> TopLevelImportHeader -> - Module () + HsModule GhcPs buildTopLevelTHHs modname tih = - mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + Ex.mkModuleE modname pkgExtensions (Just pkgExports) pkgImports pkgBody where tfns = filterTLTemplate (tihFuncs tih) pkgExtensions = - [ lang - [ "FlexibleContexts", - "FlexibleInstances", - "ForeignFunctionInterface", - "InterruptibleFFI", - "TemplateHaskell" - ] + [ "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI", + "TemplateHaskell" ] pkgExports = map - ( evar - . unqual + ( Ex.evar . (\x -> "gen" <> x <> "InstanceFor") . firstUpper . hsFrontNameForTopLevel @@ -698,15 +677,15 @@ buildTopLevelTHHs modname tih = ) tfns pkgImports = - [ mkImport "Data.Char", - mkImport "Data.List", - mkImport "Data.Monoid", - mkImport "Foreign.C.Types", - mkImport "Foreign.Ptr", - mkImport "Language.Haskell.TH", - mkImport "Language.Haskell.TH.Syntax", - mkImport "FFICXX.Runtime.CodeGen.Cxx", - mkImport "FFICXX.Runtime.TH" + [ Ex.mkImport "Data.Char", + Ex.mkImport "Data.List", + Ex.mkImport "Data.Monoid", + Ex.mkImport "Foreign.C.Types", + Ex.mkImport "Foreign.Ptr", + Ex.mkImport "Language.Haskell.TH", + Ex.mkImport "Language.Haskell.TH.Syntax", + Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", + Ex.mkImport "FFICXX.Runtime.TH" ] ++ concatMap genImportForTLTemplate tfns pkgBody = diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index b638d97d..b4b62d74 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -4,11 +4,19 @@ module FFICXX.Generate.Util.GHCExactPrint ( -- * module mkModule, + mkModuleE, - -- * import and FFI + -- * import/export and FFI + eabs, + ethingall, + ethingwith, + evar, + emodule, + eWildCard, mkImport, mkImportSrc, mkForImpCcall, + forD, -- * names unqual, @@ -86,42 +94,6 @@ module FFICXX.Generate.Util.GHCExactPrint parenSplice, typeBracket, tySplice, - {- app', - conDecl, - qualConDecl, - recDecl, - lit, - mkTVar, - mkIVar, - dhead, - mkDeclHead, - mkModuleE, - mkImportExp, - mkImportSrc, - lang, - dot, - tyParen, - tyForeignPtr, - classA, - bracketExp, - typeBracket, - irule, - ihcon, - evar, - eabs, - ethingwith, - ethingall, - emodule, - nonamespace, - insType, - insDecl, - generator, - qualifier, - unkindedVar, - if_, - urhs, - match, - eWildCard, -} -- * utility exactPrint, @@ -252,6 +224,9 @@ import Language.Haskell.Syntax HsValBinds, HsValBindsLR (..), HsWildCardBndrs (HsWC), + IE (..), + IEWildcard (..), + IEWrappedName (..), ImportDecl (..), ImportDeclQualifiedStyle (..), InstDecl (..), @@ -293,9 +268,6 @@ tokLoc nLines = TokenLoc (mkEpaDelta nLines) mkRelAnchor :: Int -> Anchor mkRelAnchor nLines = mkRelAnchor' (mkDeltaPos nLines) --- let a' = spanAsAnchor defSrcSpan --- in a' {anchor_op = MovedAnchor (mkDeltaPos nLines)} - mkRelAnchor' :: DeltaPos -> Anchor mkRelAnchor' delta = let a' = spanAsAnchor defSrcSpan @@ -304,8 +276,6 @@ mkRelAnchor' delta = mkRelEpAnn :: Int -> ann -> EpAnn ann mkRelEpAnn nLines = mkRelEpAnn' (mkDeltaPos nLines) --- EpAnn (mkRelAnchor nLines) ann emptyComments - mkRelEpAnn' :: DeltaPos -> ann -> EpAnn ann mkRelEpAnn' delta ann = EpAnn (mkRelAnchor' delta) ann emptyComments @@ -375,7 +345,20 @@ mkModule :: [ImportDecl GhcPs] -> [HsDecl GhcPs] -> HsModule GhcPs -mkModule name pragmas idecls decls = +mkModule name pragmas idecls decls = mkModuleE name pragmas Nothing idecls decls + +mkModuleE :: + -- | Module name + String -> + -- | Pragmas + [String] -> + -- | module exports + Maybe [IE GhcPs] -> + -- | imports + [ImportDecl GhcPs] -> + [HsDecl GhcPs] -> + HsModule GhcPs +mkModuleE name pragmas mies idecls decls = HsModule { hsmodExt = XModulePs @@ -385,7 +368,8 @@ mkModule name pragmas idecls decls = hsmodHaddockModHeader = Nothing }, hsmodName = Just (L (mkRelSrcSpanAnn 0 noAnnListItem) modName), - hsmodExports = Nothing, + hsmodExports = + fmap (L (mkRelSrcSpanAnn (-1) annExport) . tupleAnn) mies, hsmodImports = paragraphLines idecls, hsmodDecls = paragraphLines decls } @@ -408,6 +392,62 @@ mkModule name pragmas idecls decls = AddEpAnn AnnWhere (mkEpaDelta 0) ] (AnnList Nothing Nothing Nothing [] []) + annExport = + AnnList + Nothing + (Just (AddEpAnn AnnOpenP (mkEpaDelta 0))) + (Just (AddEpAnn AnnCloseP (mkEpaDelta (-1)))) + [] + [] + +eabs :: String -> IE GhcPs +eabs name = + IEThingAbs + (mkRelEpAnn (-1) []) + (mkL (-1) (IEName noExtField (mkLIdP (-1) name))) + +ethingall :: String -> IE GhcPs +ethingall name = + IEThingAll + (mkRelEpAnn (-1) ann) + (mkL (-1) (IEName noExtField (mkLIdP (-1) name))) + where + ann = + [ AddEpAnn AnnOpenP (mkEpaDelta (-1)), + AddEpAnn AnnCloseP (mkEpaDelta (-1)), + AddEpAnn AnnDotdot (mkEpaDelta (-1)) + ] + +ethingwith :: IEWildcard -> String -> [String] -> IE GhcPs +ethingwith wild name subs = + IEThingWith + (mkRelEpAnn (-1) ann) + (mkWrappedName name) + wild + (fmap mkWrappedName subs) + where + ann = + [ AddEpAnn AnnOpenP (mkEpaDelta (-1)), + AddEpAnn AnnCloseP (mkEpaDelta (-1)) + ] + mkWrappedName = mkL (-1) . IEName noExtField . mkLIdP (-1) + +evar :: String -> IE GhcPs +evar name = + IEVar noExtField (mkL (-1) (IEName noExtField (mkLIdP (-1) name))) + +emodule :: String -> IE GhcPs +emodule name = + IEModuleContents + (mkRelEpAnn (-1) annos) + (mkL 0 modName) + where + modName = ModuleName (fromString name) + annos = + [AddEpAnn AnnModule (mkEpaDelta (-1))] + +eWildCard :: Int -> IEWildcard +eWildCard = IEWildcard -- -- Imports @@ -496,6 +536,9 @@ mkForImpCcall quote fname typ = (StaticTarget (SourceText quote) (fromString quote) Nothing True) ) +forD :: ForeignDecl GhcPs -> HsDecl GhcPs +forD = ForD noExtField + -- -- names -- @@ -807,18 +850,6 @@ listSep sep xs = tupleAnn :: [a] -> [GenLocated SrcSpanAnnA a] tupleAnn = listSep AddCommaAnn -{- tupleAnn [] = [] -tupleAnn (x : []) = [mkL (-1) x] -tupleAnn xs = - let xs' = init xs - lastX = last xs - xs'' = - fmap - (L (mkRelSrcSpanAnn 0 (AnnListItem [AddCommaAnn (mkEpaDelta (-1))]))) - xs' - in (xs'' ++ [mkL 0 lastX]) --} - -- -- Typeclass -- @@ -1271,180 +1302,3 @@ tySplice sp = HsSpliceTy noExtField sp -- | exact print exactPrint :: (Exact.ExactPrint ast) => ast -> String exactPrint = Exact.exactPrint . Exact.makeDeltaAst - -{- -import Language.Haskell.Exts - ( Alt (..), - Asst (TypeA), - Binds, - Bracket (TypeBracket), - CallConv (CCall), - ClassDecl (ClsDecl), - ConDecl - ( ConDecl, - RecDecl - ), - Context - ( CxEmpty, - CxTuple - ), - DataOrNew - ( DataType, - NewType - ), - Decl - ( ClassDecl, - DataDecl, - ForImp, - FunBind, - InstDecl, - PatBind, - TypeSig - ), - DeclHead - ( DHApp, - DHead - ), - Deriving (..), - EWildcard (..), - Exp - ( App, - BracketExp, - Con, - If, - InfixApp, - Lit, - Var - ), - ExportSpec - ( EAbs, - EModuleContents, - EThingWith, - EVar - ), - ExportSpecList (..), - FieldDecl, - ImportDecl (..), - ImportSpec (IVar), - ImportSpecList (..), - InstDecl - ( InsDecl, - InsType - ), - InstHead - ( IHApp, - IHCon - ), - InstRule (IRule), - Literal, - Match (..), - Module (..), - ModuleHead (..), - ModuleName (..), - ModulePragma (LanguagePragma), - Name - ( Ident, - Symbol - ), - Namespace (NoNamespace), - Pat - ( PVar, - PatTypeSig - ), - QName (UnQual), - QOp (QVarOp), - QualConDecl (..), - Rhs (UnGuardedRhs), - Safety (PlayInterruptible), - Splice (ParenSplice), - Stmt - ( Generator, - Qualifier - ), - TyVarBind (UnkindedVar), - Type - ( TyApp, - TyCon, - TyForall, - TyFun, - TyList, - TyParen, - TySplice, - TyTuple, - TyVar - ), - ) -} --- import qualified Language.Haskell.Exts as LHE --- import Language.Haskell.Exts.Syntax (CName) - -{- -app :: Exp () -> Exp () -> Exp () -app = LHE.app - -app' :: String -> String -> Exp () -app' x y = App () (mkVar x) (mkVar y) - -recDecl :: String -> [FieldDecl ()] -> ConDecl () -recDecl n rs = RecDecl () (Ident () n) rs - -lit :: Literal () -> Exp () -lit = Lit () - -mkIVar :: String -> ImportSpec () -mkIVar = IVar () . Ident () - -dhead :: String -> DeclHead () -dhead n = DHead () (Ident () n) - -mkDeclHead :: String -> [TyVarBind ()] -> DeclHead () -mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds - -mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module () -mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls - where - mhead = ModuleHead () (ModuleName () n) Nothing (Just eslist) - eslist = ExportSpecList () exps - -mkImportExp :: String -> [String] -> ImportDecl () -mkImportExp m lst = - ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist) - where - islist = ImportSpecList () False (map mkIVar lst) - -dot :: Exp () -> Exp () -> Exp () -x `dot` y = x `app` mkVar "." `app` y - -tyForeignPtr :: Type () -tyForeignPtr = tycon "ForeignPtr" - -evar :: QName () -> ExportSpec () -evar = EVar () - -eabs :: Namespace () -> QName () -> ExportSpec () -eabs = EAbs () - -ethingwith :: - EWildcard () -> - QName () -> - [Language.Haskell.Exts.Syntax.CName ()] -> - ExportSpec () -ethingwith = EThingWith () - -ethingall :: QName () -> ExportSpec () -ethingall q = ethingwith (EWildcard () 0) q [] - -emodule :: String -> ExportSpec () -emodule nm = EModuleContents () (ModuleName () nm) - -nonamespace :: Namespace () -nonamespace = NoNamespace () - -if_ :: Exp () -> Exp () -> Exp () -> Exp () -if_ = If () - -urhs :: Exp () -> Rhs () -urhs = UnGuardedRhs () - -eWildCard :: Int -> EWildcard () -eWildCard = EWildcard () --} diff --git a/fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs b/fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs deleted file mode 100644 index 60c547fb..00000000 --- a/fficxx/src/FFICXX/Generate/Util/HaskellSrcExts.hs +++ /dev/null @@ -1,452 +0,0 @@ -module FFICXX.Generate.Util.HaskellSrcExts - ( app, - app', - unqual, - tycon, - tyapp, - tyfun, - tylist, - unit_tycon, - conDecl, - qualConDecl, - recDecl, - lit, - mkVar, - con, - doE, - listE, - strE, - qualStmt, - mkTVar, - mkPVar, - mkIVar, - mkPVarSig, - pbind, - pbind_, - mkTBind, - mkBind1, - mkFun, - mkFunSig, - mkClass, - dhead, - mkDeclHead, - mkInstance, - mkData, - mkNewtype, - mkForImpCcall, - mkModule, - mkModuleE, - mkImport, - mkImportExp, - mkImportSrc, - lang, - dot, - tyForall, - tyParen, - tyPtr, - tyForeignPtr, - classA, - cxEmpty, - cxTuple, - tySplice, - tyTupleBoxed, - parenSplice, - bracketExp, - typeBracket, - mkDeriving, - irule, - ihcon, - evar, - eabs, - ethingwith, - ethingall, - emodule, - nonamespace, - insType, - insDecl, - generator, - qualifier, - clsDecl, - unkindedVar, - op, - inapp, - if_, - urhs, - match, - eWildCard, - prettyPrint, - ) -where - -import Data.List (foldl') -import Data.Maybe (maybeToList) -import Language.Haskell.Exts - ( Alt (..), - Asst (TypeA), - Binds, - Bracket (TypeBracket), - CallConv (CCall), - ClassDecl (ClsDecl), - ConDecl - ( ConDecl, - RecDecl - ), - Context - ( CxEmpty, - CxTuple - ), - DataOrNew - ( DataType, - NewType - ), - Decl - ( ClassDecl, - DataDecl, - ForImp, - FunBind, - InstDecl, - PatBind, - TypeSig - ), - DeclHead - ( DHApp, - DHead - ), - Deriving (..), - EWildcard (..), - Exp - ( App, - BracketExp, - Con, - If, - InfixApp, - Lit, - Var - ), - ExportSpec - ( EAbs, - EModuleContents, - EThingWith, - EVar - ), - ExportSpecList (..), - FieldDecl, - ImportDecl (..), - ImportSpec (IVar), - ImportSpecList (..), - InstDecl - ( InsDecl, - InsType - ), - InstHead - ( IHApp, - IHCon - ), - InstRule (IRule), - Literal, - Match (..), - Module (..), - ModuleHead (..), - ModuleName (..), - ModulePragma (LanguagePragma), - Name - ( Ident, - Symbol - ), - Namespace (NoNamespace), - Pat - ( PVar, - PatTypeSig - ), - QName (UnQual), - QOp (QVarOp), - QualConDecl (..), - Rhs (UnGuardedRhs), - Safety (PlayInterruptible), - Splice (ParenSplice), - Stmt - ( Generator, - Qualifier - ), - TyVarBind (UnkindedVar), - Type - ( TyApp, - TyCon, - TyForall, - TyFun, - TyList, - TyParen, - TySplice, - TyTuple, - TyVar - ), - ) -import qualified Language.Haskell.Exts as LHE -import Language.Haskell.Exts.Syntax (CName) - -app :: Exp () -> Exp () -> Exp () -app = LHE.app - -app' :: String -> String -> Exp () -app' x y = App () (mkVar x) (mkVar y) - -unqual :: String -> QName () -unqual = UnQual () . Ident () - -tycon :: String -> Type () -tycon = TyCon () . unqual - -tyapp :: Type () -> Type () -> Type () -tyapp = TyApp () - -infixl 2 `tyapp` - -tyfun :: Type () -> Type () -> Type () -tyfun = TyFun () - -infixr 2 `tyfun` - -tylist :: Type () -> Type () -tylist = TyList () - -unit_tycon :: Type () -unit_tycon = LHE.unit_tycon () - -conDecl :: String -> [Type ()] -> ConDecl () -conDecl n ys = ConDecl () (Ident () n) ys - -qualConDecl :: - Maybe [TyVarBind ()] -> - Maybe (Context ()) -> - ConDecl () -> - QualConDecl () -qualConDecl = QualConDecl () - -recDecl :: String -> [FieldDecl ()] -> ConDecl () -recDecl n rs = RecDecl () (Ident () n) rs - -lit :: Literal () -> Exp () -lit = Lit () - -mkVar :: String -> Exp () -mkVar = Var () . unqual - -con :: String -> Exp () -con = Con () . unqual - -doE :: [Stmt ()] -> Exp () -doE = LHE.doE - -listE :: [Exp ()] -> Exp () -listE = LHE.listE - -strE :: String -> Exp () -strE = LHE.strE - -qualStmt :: Exp () -> Stmt () -qualStmt = LHE.qualStmt - -mkTVar :: String -> Type () -mkTVar = TyVar () . Ident () - -mkPVar :: String -> Pat () -mkPVar = PVar () . Ident () - -mkIVar :: String -> ImportSpec () -mkIVar = IVar () . Ident () - -mkPVarSig :: String -> Type () -> Pat () -mkPVarSig n typ = PatTypeSig () (mkPVar n) typ - -pbind :: Pat () -> Exp () -> Maybe (Binds ()) -> Decl () -pbind pat e = PatBind () pat (UnGuardedRhs () e) - -pbind_ :: Pat () -> Exp () -> Decl () -pbind_ p e = pbind p e Nothing - -mkTBind :: String -> TyVarBind () -mkTBind = UnkindedVar () . Ident () - -mkBind1 :: String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl () -mkBind1 n pat rhs mbinds = - FunBind () [Match () (Ident () n) pat (UnGuardedRhs () rhs) mbinds] - -mkFun :: String -> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()] -mkFun fname typ pats rhs mbinds = [mkFunSig fname typ, mkBind1 fname pats rhs mbinds] - -mkFunSig :: String -> Type () -> Decl () -mkFunSig fname typ = TypeSig () [Ident () fname] typ - -mkClass :: Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl () -mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds) [] (Just cdecls) - -dhead :: String -> DeclHead () -dhead n = DHead () (Ident () n) - -mkDeclHead :: String -> [TyVarBind ()] -> DeclHead () -mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds - -mkInstance :: Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl () -mkInstance ctxt n typs idecls = InstDecl () Nothing instrule (Just idecls) - where - instrule = IRule () Nothing (Just ctxt) insthead - insthead = foldl' f (IHCon () (unqual n)) typs - where - f acc x = IHApp () acc (tyParen x) - -mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () -mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv) - where - declhead = mkDeclHead n tbinds - -mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () -mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv) - where - declhead = mkDeclHead n tbinds - -mkForImpCcall :: String -> String -> Type () -> Decl () -mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlayInterruptible ())) (Just quote) (Ident () n) typ - -mkModule :: String -> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module () -mkModule n pragmas idecls decls = Module () (Just mhead) pragmas idecls decls - where - mhead = ModuleHead () (ModuleName () n) Nothing Nothing - -mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module () -mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls - where - mhead = ModuleHead () (ModuleName () n) Nothing (Just eslist) - eslist = ExportSpecList () exps - -mkImport :: String -> ImportDecl () -mkImport m = ImportDecl () (ModuleName () m) False False False Nothing Nothing Nothing - -mkImportExp :: String -> [String] -> ImportDecl () -mkImportExp m lst = - ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist) - where - islist = ImportSpecList () False (map mkIVar lst) - -mkImportSrc :: String -> ImportDecl () -mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing - -lang :: [String] -> ModulePragma () -lang ns = LanguagePragma () (map (Ident ()) ns) - -dot :: Exp () -> Exp () -> Exp () -x `dot` y = x `app` mkVar "." `app` y - -tyForall :: - Maybe [TyVarBind ()] -> - Maybe (Context ()) -> - Type () -> - Type () -tyForall = TyForall () - -tyParen :: Type () -> Type () -tyParen = TyParen () - -tyPtr :: Type () -tyPtr = tycon "Ptr" - -tyForeignPtr :: Type () -tyForeignPtr = tycon "ForeignPtr" - -classA :: QName () -> [Type ()] -> Asst () -classA n = TypeA () . foldl' tyapp (TyCon () n) - -cxEmpty :: Context () -cxEmpty = CxEmpty () - -cxTuple :: [Asst ()] -> Context () -cxTuple = CxTuple () - -tySplice :: Splice () -> Type () -tySplice = TySplice () - -tyTupleBoxed :: [Type ()] -> Type () -tyTupleBoxed = TyTuple () LHE.Boxed - -parenSplice :: Exp () -> Splice () -parenSplice = ParenSplice () - -bracketExp :: Bracket () -> Exp () -bracketExp = BracketExp () - -typeBracket :: Type () -> Bracket () -typeBracket = TypeBracket () - -mkDeriving :: [InstRule ()] -> Deriving () -mkDeriving = Deriving () Nothing - -irule :: - Maybe [TyVarBind ()] -> - Maybe (Context ()) -> - InstHead () -> - InstRule () -irule = IRule () - -ihcon :: QName () -> InstHead () -ihcon = IHCon () - -evar :: QName () -> ExportSpec () -evar = EVar () - -eabs :: Namespace () -> QName () -> ExportSpec () -eabs = EAbs () - -ethingwith :: - EWildcard () -> - QName () -> - [Language.Haskell.Exts.Syntax.CName ()] -> - ExportSpec () -ethingwith = EThingWith () - -ethingall :: QName () -> ExportSpec () -ethingall q = ethingwith (EWildcard () 0) q [] - -emodule :: String -> ExportSpec () -emodule nm = EModuleContents () (ModuleName () nm) - -nonamespace :: Namespace () -nonamespace = NoNamespace () - -insType :: Type () -> Type () -> InstDecl () -insType = InsType () - -insDecl :: Decl () -> InstDecl () -insDecl = InsDecl () - -generator :: Pat () -> Exp () -> Stmt () -generator = Generator () - -qualifier :: Exp () -> Stmt () -qualifier = Qualifier () - -clsDecl :: Decl () -> ClassDecl () -clsDecl = ClsDecl () - -unkindedVar :: Name () -> TyVarBind () -unkindedVar = UnkindedVar () - -op :: String -> QOp () -op = QVarOp () . UnQual () . Symbol () - -inapp :: Exp () -> QOp () -> Exp () -> Exp () -inapp = InfixApp () - -if_ :: Exp () -> Exp () -> Exp () -> Exp () -if_ = If () - -urhs :: Exp () -> Rhs () -urhs = UnGuardedRhs () - --- | case pattern match p -> e -match :: Pat () -> Exp () -> Alt () -match p e = Alt () p (urhs e) Nothing - -eWildCard :: Int -> EWildcard () -eWildCard = EWildcard () - -prettyPrint :: (LHE.Pretty a) => a -> String -prettyPrint = LHE.prettyPrint From a1ce045ef302708dcb9c72c32c8edaefbf25c55f Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Mon, 14 Aug 2023 13:44:25 -0700 Subject: [PATCH 12/19] First data-type support of C/C++ enums (#222) C/C++ enum is now translated to a Haskell data type. * introduce CPTEnum case. * remove old CEnum * Enum data type generation * Enum generation is using hsc2hs. --cc=c++ --ld=c++ option * build fix * format Enum-generated data type * introduce DeclGroup * standalone comment generation (for #include statement) * Enum instance generation (only succ/pred) * mkBind * fromEnum generation! * remove stale code * format fix --- experiments/sample.hs | 9 +- fficxx-multipkg-test/template-dep/Gen.hs | 1 + fficxx-multipkg-test/template-member/Gen.hs | 1 + fficxx-multipkg-test/template-toplevel/Gen.hs | 1 + fficxx/fficxx.cabal | 1 + fficxx/src/FFICXX/Generate/Builder.hs | 8 + fficxx/src/FFICXX/Generate/Code/Cabal.hs | 11 +- fficxx/src/FFICXX/Generate/Code/Cpp.hs | 2 + fficxx/src/FFICXX/Generate/Code/HsEnum.hs | 77 +++++++++ fficxx/src/FFICXX/Generate/Code/Primitive.hs | 15 +- fficxx/src/FFICXX/Generate/Config.hs | 3 +- fficxx/src/FFICXX/Generate/ContentMaker.hs | 91 +++++++---- fficxx/src/FFICXX/Generate/Dependency.hs | 1 + fficxx/src/FFICXX/Generate/Name.hs | 20 ++- fficxx/src/FFICXX/Generate/Type/Cabal.hs | 16 +- fficxx/src/FFICXX/Generate/Type/Class.hs | 13 +- .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 147 +++++++++++++++--- stdcxx-gen/Gen.hs | 5 + 18 files changed, 356 insertions(+), 66 deletions(-) create mode 100644 fficxx/src/FFICXX/Generate/Code/HsEnum.hs diff --git a/experiments/sample.hs b/experiments/sample.hs index 374f01e8..795b2920 100644 --- a/experiments/sample.hs +++ b/experiments/sample.hs @@ -4,5 +4,10 @@ module MyModule where -f :: Double -> Double -f x = [1, 2] +instance Test F where + f True = 1 + f False = 0 + +test = test1 {- abc -} + +test2 = test3 diff --git a/fficxx-multipkg-test/template-dep/Gen.hs b/fficxx-multipkg-test/template-dep/Gen.hs index 53ce2045..7c4ef7ac 100644 --- a/fficxx-multipkg-test/template-dep/Gen.hs +++ b/fficxx-multipkg-test/template-dep/Gen.hs @@ -185,6 +185,7 @@ main = do sbcModUnitMap = ModuleUnitMap (HM.fromList headers), sbcCabal = cabal, sbcClasses = classes cabal, + sbcEnums = [], sbcTopLevels = toplevels, sbcTemplates = templates cabal, sbcExtraLibs = extraLib, diff --git a/fficxx-multipkg-test/template-member/Gen.hs b/fficxx-multipkg-test/template-member/Gen.hs index 30e2d110..4e1d474a 100644 --- a/fficxx-multipkg-test/template-member/Gen.hs +++ b/fficxx-multipkg-test/template-member/Gen.hs @@ -291,6 +291,7 @@ main = do sbcModUnitMap = ModuleUnitMap (HM.fromList headers), sbcCabal = cabal, sbcClasses = classes cabal, + sbcEnums = [], sbcTopLevels = toplevels, sbcTemplates = templates, sbcExtraLibs = extraLib, diff --git a/fficxx-multipkg-test/template-toplevel/Gen.hs b/fficxx-multipkg-test/template-toplevel/Gen.hs index 03175818..0a87d8ce 100644 --- a/fficxx-multipkg-test/template-toplevel/Gen.hs +++ b/fficxx-multipkg-test/template-toplevel/Gen.hs @@ -209,6 +209,7 @@ main = do sbcModUnitMap = ModuleUnitMap (HM.fromList headers), sbcCabal = cabal, sbcClasses = classes cabal, + sbcEnums = [], sbcTopLevels = toplevels, sbcTemplates = templates cabal, sbcExtraLibs = extraLib, diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index ccec9daf..2b01a06c 100644 --- a/fficxx/fficxx.cabal +++ b/fficxx/fficxx.cabal @@ -56,6 +56,7 @@ Library FFICXX.Generate.Code.Cpp FFICXX.Generate.Code.HsCast FFICXX.Generate.Code.HsCommon + FFICXX.Generate.Code.HsEnum FFICXX.Generate.Code.HsFFI FFICXX.Generate.Code.HsImplementation FFICXX.Generate.Code.HsInterface diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 05033f09..a2d8c724 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -88,6 +88,7 @@ simpleBuilder cfg sbc = do mumap cabal classes + enums toplevelfunctions templates extralibs @@ -155,6 +156,12 @@ simpleBuilder cfg sbc = do for_ (cabal_additional_c_incs cabal) (\(AddCInc hdr txt) -> gen hdr txt) for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt) -- + putStrLn "Generating Enum.hsc" + debugExactPrint (C.buildEnumHsc mempty (topLevelMod <> ".Enum") enums) + gen + (topLevelMod <.> "Enum" <.> "hsc") + (exactPrint (C.buildEnumHsc mempty (topLevelMod <> ".Enum") enums)) + -- putStrLn "Generating RawType.hs" for_ mods $ \m -> gen @@ -250,6 +257,7 @@ simpleBuilder cfg sbc = do for_ mods (copyModule workingDir (C.srcDir installDir)) for_ tcms (copyTemplateModule workingDir (C.srcDir installDir)) putStrLn "Copying Ordinary" + moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Enum" <.> "hsc" moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Ordinary" <.> "hs" moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Template" <.> "hs" moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "TH" <.> "hs" diff --git a/fficxx/src/FFICXX/Generate/Code/Cabal.hs b/fficxx/src/FFICXX/Generate/Code/Cabal.hs index 7c699752..f04f9728 100644 --- a/fficxx/src/FFICXX/Generate/Code/Cabal.hs +++ b/fficxx/src/FFICXX/Generate/Code/Cabal.hs @@ -111,7 +111,12 @@ genExposedModules summarymod (cmods, tmods) = $ cmods template = map ((<> ".Template") . tcmModule) tmods th = map ((<> ".TH") . tcmModule) tmods - in [summarymod, summarymod <> ".Ordinary", summarymod <> ".Template", summarymod <> ".TH"] + in [ summarymod, + summarymod <> ".Ordinary", + summarymod <> ".Template", + summarymod <> ".TH", + summarymod <> ".Enum" + ] <> cmodstrs <> rawType <> ffi @@ -137,7 +142,7 @@ genPkgDeps cs = cabalTemplate :: Text cabalTemplate = - "Cabal-version: 3.0\n\ + "Cabal-version: 3.6\n\ \Name: $pkgname\n\ \Version: $version\n\ \Synopsis: $synopsis\n\ @@ -160,7 +165,7 @@ cabalTemplate = \ default-language: Haskell2010\n\ \ hs-source-dirs: src\n\ \ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports\n\ - \ ghc-prof-options: -caf-all -auto-all\n\ + \ hsc2hs-options: --cc=c++ --ld=c++\n\ \ cxx-options: $cxxOptions\n\ \ Build-Depends: $pkgdeps\n\ \ Exposed-Modules:\n\ diff --git a/fficxx/src/FFICXX/Generate/Code/Cpp.hs b/fficxx/src/FFICXX/Generate/Code/Cpp.hs index 81907b98..15991d05 100644 --- a/fficxx/src/FFICXX/Generate/Code/Cpp.hs +++ b/fficxx/src/FFICXX/Generate/Code/Cpp.hs @@ -384,6 +384,8 @@ returnCpp b ret caller = [R.CReturn $ R.CAddr caller] CT _ _ -> [R.CReturn caller] + CPT (CPTEnum _) _ -> + [R.CReturn caller] CPT (CPTClass c') isconst -> [ R.CReturn $ R.CTApp diff --git a/fficxx/src/FFICXX/Generate/Code/HsEnum.hs b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs new file mode 100644 index 00000000..2a5e1b1d --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs @@ -0,0 +1,77 @@ +module FFICXX.Generate.Code.HsEnum + ( genHsEnumInclude, + genHsEnumDecl, + ) +where + +import Control.Monad.Reader (Reader) +import FFICXX.Generate.Name + ( enumDataConstructorNames, + enumDataTypeName, + ) +import FFICXX.Generate.Type.Annotate (AnnotateMap) +import FFICXX.Generate.Type.Class (EnumType (..)) +import FFICXX.Generate.Util.GHCExactPrint + ( DeclGroup, + app, + comment, + conDecl, + cxEmpty, + instD, + mkBind, + mkData, + mkDeriving, + mkInstance, + mkPVar, + mkVar, + mkVarWithComment, + tycon, + wildcard, + ) +import GHC.Hs (GhcPs) +import GHC.Parser.Annotation (DeltaPos (..)) +import Language.Haskell.Syntax + ( HsDecl (DocD, TyClD), + HsLocalBindsLR (..), + noExtField, + ) + +genHsEnumInclude :: EnumType -> DeclGroup +genHsEnumInclude enum = + comment incstr + where + incstr = "#include \"" <> enum_header enum <> "\"" + +genHsEnumDecl :: EnumType -> [HsDecl GhcPs] +genHsEnumDecl enum = + [ TyClD noExtField datDecl, + instD enumInstDecl + ] + where + typ = enumDataTypeName enum + cnstrs = enumDataConstructorNames enum + cnstrExps = + fmap (\n -> conDecl n []) cnstrs + deriv = + mkDeriving [tycon "Eq", tycon "Ord", tycon "Show"] + datDecl = mkData typ [] cnstrExps deriv + -- + mk1to1 (x, y) = ([mkPVar x], mkVar y, EmptyLocalBinds noExtField) + mkFromIntegralCxx x = + mkVar "fromIntegral" + `app` mkVarWithComment "" ("#{const " <> x <> "}") + -- NOTE: toEnum should not be used. + -- TODO: make this somewhat safer with error messages. + mkToEnum = [([wildcard], mkVar "undefined", EmptyLocalBinds noExtField)] + mkFromEnum x = + ( [mkPVar x], + mkFromIntegralCxx x, + EmptyLocalBinds noExtField + ) + bnds = + [ mkBind (DifferentLine 1 2) "succ" (fmap mk1to1 (zip cnstrs (tail cnstrs))), + mkBind (DifferentLine 1 2) "pred" (fmap mk1to1 (zip (tail cnstrs) cnstrs)), + mkBind (DifferentLine 1 2) "toEnum" mkToEnum, + mkBind (DifferentLine 1 2) "fromEnum" (fmap mkFromEnum cnstrs) + ] + enumInstDecl = mkInstance cxEmpty "Enum" [tycon typ] [] bnds diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index e2e77115..2008ff95 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -96,7 +96,6 @@ ctypToCType ctyp isconst = CTUInt64 -> R.CTSimple $ R.sname "uint64_t" CTString -> R.CTStar $ R.CTSimple $ R.sname "char" CTVoidStar -> R.CTStar R.CTVoid - CEnum _ type_str -> R.CTVerbatim type_str CPointer s -> R.CTStar (ctypToCType s NoConst) CRef s -> R.CTStar (ctypToCType s NoConst) in case isconst of @@ -339,6 +338,8 @@ returnCType :: Types -> R.CType Identity returnCType (CT ctyp isconst) = ctypToCType ctyp isconst returnCType Void = R.CTVoid returnCType SelfType = R.CTSimple (R.CName [R.NamePart "Type", R.NamePart "_p"]) +-- TODO: for now, weakly typed enum. +returnCType (CPT (CPTEnum _) _) = ctypToCType CTInt Const returnCType (CPT (CPTClass c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) returnCType (CPT (CPTClassRef c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) returnCType (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) @@ -420,6 +421,8 @@ cxx2C t e = -- "&(" <> e <> ")" CT _ _ -> e -- e + CPT (CPTEnum _) _ -> e + -- e CPT (CPTClass c) _ -> R.CTApp (R.sname "from_nonconst_to_nonconst") @@ -604,6 +607,7 @@ tmplReturnCType :: tmplReturnCType _ (CT ctyp isconst) = ctypToCType ctyp isconst tmplReturnCType _ Void = R.CTVoid tmplReturnCType _ SelfType = R.CTStar R.CTVoid +tmplReturnCType _ (CPT (CPTEnum _) _) = ctypToCType CTInt Const tmplReturnCType _ (CPT (CPTClass c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) tmplReturnCType _ (CPT (CPTClassRef c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) tmplReturnCType _ (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) @@ -628,6 +632,8 @@ tmplMemFuncArgToCTypVar _ (Arg (CT ctyp isconst) varname) = (ctypToCType ctyp isconst, R.sname varname) tmplMemFuncArgToCTypVar c (Arg SelfType varname) = (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTEnum _) _) varname) = + (ctypToCType CTInt Const, R.sname varname) tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTClass c) isconst) varname) = case isconst of Const -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname) @@ -652,6 +658,7 @@ tmplMemFuncReturnCType :: Class -> Types -> R.CType Identity tmplMemFuncReturnCType _ (CT ctyp isconst) = ctypToCType ctyp isconst tmplMemFuncReturnCType _ Void = R.CTVoid tmplMemFuncReturnCType c SelfType = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplMemFuncReturnCType _ (CPT (CPTEnum _) _) = ctypToCType CTInt Const tmplMemFuncReturnCType _ (CPT (CPTClass c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) tmplMemFuncReturnCType _ (CPT (CPTClassRef c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) tmplMemFuncReturnCType _ (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) @@ -663,7 +670,6 @@ tmplMemFuncReturnCType _ (TemplateType _) = R.CTStar R.CTVoid tmplMemFuncReturnCType _ (TemplateParam t) = R.CTSimple $ R.CName [R.NamePart t, R.NamePart "_p"] tmplMemFuncReturnCType _ (TemplateParamPointer t) = R.CTSimple $ R.CName [R.NamePart t, R.NamePart "_p"] --- new c2HsType :: CTypes -> HsType GhcPs c2HsType CTBool = Ex.tycon "CBool" c2HsType CTChar = Ex.tycon "CChar" @@ -704,7 +710,6 @@ c2HsType CTUInt32 = Ex.tycon "Word32" c2HsType CTUInt64 = Ex.tycon "Word64" c2HsType CTString = Ex.tycon "CString" c2HsType CTVoidStar = Ex.tyapp (Ex.tycon "Ptr") Ex.unit_tycon -c2HsType (CEnum t _) = c2HsType t c2HsType (CPointer t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) c2HsType (CRef t) = Ex.tyapp (Ex.tycon "Ptr") (c2HsType t) @@ -713,6 +718,7 @@ cxx2HsType _c Void = Ex.unit_tycon cxx2HsType (Just c) SelfType = Ex.tycon ((fst . hsClassName) c) cxx2HsType Nothing SelfType = error "cxx2HsType : SelfType but no class " cxx2HsType _c (CT t _) = c2HsType t +cxx2HsType _c (CPT (CPTEnum _) _) = c2HsType CTInt cxx2HsType _c (CPT (CPTClass c') _) = (Ex.tycon . fst . hsClassName) c' cxx2HsType _c (CPT (CPTClassRef c') _) = (Ex.tycon . fst . hsClassName) c' cxx2HsType _c (CPT (CPTClassCopy c') _) = (Ex.tycon . fst . hsClassName) c' @@ -747,6 +753,7 @@ cxx2HsType4Tmpl _ c _ Void = cxx2HsType c Void cxx2HsType4Tmpl _ (Just c) _ SelfType = cxx2HsType (Just c) SelfType cxx2HsType4Tmpl _ Nothing _ SelfType = cxx2HsType Nothing SelfType cxx2HsType4Tmpl _ c _ x@(CT _ _) = cxx2HsType c x +cxx2HsType4Tmpl _ c _ x@(CPT (CPTEnum _) _) = cxx2HsType c x cxx2HsType4Tmpl _ c _ x@(CPT (CPTClass _) _) = cxx2HsType c x cxx2HsType4Tmpl _ c _ x@(CPT (CPTClassRef _) _) = cxx2HsType c x cxx2HsType4Tmpl _ c _ x@(CPT (CPTClassCopy _) _) = cxx2HsType c x @@ -869,7 +876,6 @@ functionSignature c f = | otherwise = id in Ex.qualTy ctxt (foldr1 Ex.tyfun (arg0 typs)) --- NEW functionSignatureT :: TemplateClass -> TemplateFunction -> HsType GhcPs functionSignatureT t TFun {..} = let (hname, _) = hsTemplateClassName t @@ -1017,6 +1023,7 @@ hsFFIFunType msc (CFunSig args ret) = hsrettype Void = Ex.unit_tycon hsrettype SelfType = selftyp hsrettype (CT ctype _) = c2HsType ctype + hsrettype (CPT (CPTEnum _) _) = c2HsType CTInt hsrettype (CPT (CPTClass d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) where rawname = snd (hsClassName d) diff --git a/fficxx/src/FFICXX/Generate/Config.hs b/fficxx/src/FFICXX/Generate/Config.hs index 8337f635..75f5dee8 100644 --- a/fficxx/src/FFICXX/Generate/Config.hs +++ b/fficxx/src/FFICXX/Generate/Config.hs @@ -1,7 +1,7 @@ module FFICXX.Generate.Config where import FFICXX.Generate.Type.Cabal (Cabal) -import FFICXX.Generate.Type.Class (Class, TopLevel) +import FFICXX.Generate.Type.Class (Class, EnumType, TopLevel) import FFICXX.Generate.Type.Config (ModuleUnitMap (..)) import FFICXX.Generate.Type.Module (TemplateClassImportHeader) @@ -17,6 +17,7 @@ data SimpleBuilderConfig = SimpleBuilderConfig sbcModUnitMap :: ModuleUnitMap, sbcCabal :: Cabal, sbcClasses :: [Class], + sbcEnums :: [EnumType], sbcTopLevels :: [TopLevel], sbcTemplates :: [TemplateClassImportHeader], sbcExtraLibs :: [String], diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 0a5d5e3c..50c6be01 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -7,7 +7,7 @@ import Control.Lens (at, (&), (.~)) import Control.Monad.Trans.Reader (runReader) import Data.Either (rights) import Data.Functor.Identity (Identity) -import Data.List (intercalate, nub) +import Data.List (intercalate, nub, singleton) import qualified Data.Map as M import Data.Maybe (mapMaybe) import FFICXX.Generate.Code.Cpp @@ -37,6 +37,11 @@ import FFICXX.Generate.Code.HsCast import FFICXX.Generate.Code.HsCommon ( genExtraImport, ) +import FFICXX.Generate.Code.HsEnum + ( genHsEnumDecl, + -- genHsEnumFFI, + genHsEnumInclude, + ) import FFICXX.Generate.Code.HsFFI ( genHsFFI, genImportInFFI, @@ -94,6 +99,7 @@ import FFICXX.Generate.Type.Class ( Class (..), ClassGlobal (..), DaughterMap, + EnumType (..), ProtectedMethod (..), TopLevel (TLOrdinary, TLTemplate), filterTLOrdinary, @@ -343,7 +349,7 @@ buildFFIHsc m = ] <> genImportInFFI m <> genExtraImport m - hscBody = fmap Ex.forD (genHsFFI (cmCIH m)) + hscBody = singleton $ Ex.DeclGroup $ fmap Ex.forD (genHsFFI (cmCIH m)) buildRawTypeHs :: ClassModule -> HsModule GhcPs buildRawTypeHs m = @@ -366,8 +372,9 @@ buildRawTypeHs m = Ex.mkImport "FFICXX.Runtime.Cast" ] rawtypeBody = - let c = cihClass (cmCIH m) - in if isAbstractClass c then [] else hsClassRawType c + singleton . Ex.DeclGroup $ + let c = cihClass (cmCIH m) + in if isAbstractClass c then [] else hsClassRawType c buildInterfaceHs :: AnnotateMap -> @@ -401,9 +408,10 @@ buildInterfaceHs amap depCycles m = <> genImportInInterface False depCycles m <> genExtraImport m ifaceBody = - runReader (mapM (genHsFrontDecl False) classes) amap - <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes - <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes + singleton . Ex.DeclGroup $ + runReader (traverse (genHsFrontDecl False) classes) amap + <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes + <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes buildInterfaceHsBoot :: DepCycles -> ClassModule -> HsModule GhcPs buildInterfaceHsBoot depCycles m = @@ -432,7 +440,8 @@ buildInterfaceHsBoot depCycles m = ] <> genImportInInterface True depCycles m <> genExtraImport m - hsbootBody = runReader (mapM (genHsFrontDecl True) [c]) M.empty + hsbootBody = + singleton . Ex.DeclGroup $ runReader (mapM (genHsFrontDecl True) [c]) M.empty buildCastHs :: ClassModule -> HsModule GhcPs buildCastHs m = @@ -456,8 +465,9 @@ buildCastHs m = ] <> genImportInCast m body = - mapMaybe genHsFrontInstCastable classes - <> mapMaybe genHsFrontInstCastableSelf classes + singleton . Ex.DeclGroup $ + mapMaybe genHsFrontInstCastable classes + <> mapMaybe genHsFrontInstCastableSelf classes buildImplementationHs :: AnnotateMap -> ClassModule -> HsModule GhcPs buildImplementationHs amap m = @@ -497,12 +507,13 @@ buildImplementationHs amap m = f :: Class -> [HsDecl GhcPs] f y = concatMap (flip genHsFrontInst y) (y : class_allparents y) implBody = - concatMap f classes - <> runReader (concat <$> mapM genHsFrontInstNew classes) amap - <> concatMap genHsFrontInstNonVirtual classes - <> concatMap genHsFrontInstStatic classes - <> concatMap genHsFrontInstVariables classes - <> genTemplateMemberFunctions (cmCIH m) + singleton . Ex.DeclGroup $ + concatMap f classes + <> runReader (concat <$> mapM genHsFrontInstNew classes) amap + <> concatMap genHsFrontInstNonVirtual classes + <> concatMap genHsFrontInstStatic classes + <> concatMap genHsFrontInstVariables classes + <> genTemplateMemberFunctions (cmCIH m) buildProxyHs :: ClassModule -> HsModule GhcPs buildProxyHs m = @@ -520,7 +531,7 @@ buildProxyHs m = ] body where - body = genProxyInstance + body = singleton . Ex.DeclGroup $ genProxyInstance buildTemplateHs :: TemplateClassModule -> HsModule GhcPs buildTemplateHs m = @@ -541,7 +552,7 @@ buildTemplateHs m = Ex.mkImport "FFICXX.Runtime.Cast" ] <> genImportInTemplate t - body = genTmplInterface t + body = singleton . Ex.DeclGroup $ genTmplInterface t buildTHHs :: TemplateClassModule -> HsModule GhcPs buildTHHs m = @@ -566,16 +577,41 @@ buildTHHs m = imports = [Ex.mkImport (tcmModule m <.> "Template")] <> genImportInTH t - body = tmplImpls <> tmplInsts tmplImpls = genTmplImplementation t tmplInsts = genTmplInstance (tcmTCIH m) + body = + singleton . Ex.DeclGroup $ + tmplImpls <> tmplInsts buildModuleHs :: ClassModule -> HsModule GhcPs buildModuleHs m = - Ex.mkModuleE (cmModule m) [] (Just (genExport c)) (genImportInModule c) [] + Ex.mkModuleE + (cmModule m) + [] + (Just (genExport c)) + (genImportInModule c) + (singleton . Ex.DeclGroup $ []) where c = cihClass (cmCIH m) +buildEnumHsc :: + AnnotateMap -> + String -> + [EnumType] -> + HsModule GhcPs +buildEnumHsc amap modname enums = + Ex.mkModuleE modname [] Nothing [] body + where + body = + concatMap + ( \enum -> + [ genHsEnumInclude enum, + Ex.DeclGroup (genHsEnumDecl enum) + -- , genHsEnumFFI enum]) + ] + ) + enums + buildTopLevelHs :: String -> ([ClassModule], [TemplateClassModule]) -> @@ -593,8 +629,7 @@ buildTopLevelHs modname (mods, tmods) = map (Ex.emodule . cmModule) mods ++ map Ex.emodule [modname <.> "Ordinary", modname <.> "Template", modname <.> "TH"] pkgImports = genImportInTopLevel modname (mods, tmods) - pkgBody = [] -- map (genTopLevelFFI tih) (filterTLOrdinary tfns) - -- ++ concatMap genTopLevelDef (filterTLOrdinary tfns) + pkgBody = singleton . Ex.DeclGroup $ [] buildTopLevelOrdinaryHs :: String -> @@ -617,8 +652,9 @@ buildTopLevelOrdinaryHs modname (_mods, tmods) tih = ++ fmap (\m -> Ex.mkImport (tcmModule m <.> "Template")) tmods ++ concatMap genImportForTLOrdinary (filterTLOrdinary tfns) pkgBody = - map (Ex.forD . genTopLevelFFI tih) (filterTLOrdinary tfns) - ++ concatMap genTopLevelDef (filterTLOrdinary tfns) + singleton . Ex.DeclGroup $ + map (Ex.forD . genTopLevelFFI tih) (filterTLOrdinary tfns) + ++ concatMap genTopLevelDef (filterTLOrdinary tfns) buildTopLevelTemplateHs :: String -> @@ -650,7 +686,7 @@ buildTopLevelTemplateHs modname tih = Ex.mkImport "FFICXX.Runtime.Cast" ] ++ concatMap genImportForTLTemplate tfns - pkgBody = concatMap genTLTemplateInterface tfns + pkgBody = singleton . Ex.DeclGroup $ concatMap genTLTemplateInterface tfns buildTopLevelTHHs :: String -> @@ -689,8 +725,9 @@ buildTopLevelTHHs modname tih = ] ++ concatMap genImportForTLTemplate tfns pkgBody = - concatMap genTLTemplateImplementation tfns - <> concatMap (genTLTemplateInstance tih) tfns + singleton . Ex.DeclGroup $ + concatMap genTLTemplateImplementation tfns + <> concatMap (genTLTemplateInstance tih) tfns buildPackageInterface :: PackageInterface -> diff --git a/fficxx/src/FFICXX/Generate/Dependency.hs b/fficxx/src/FFICXX/Generate/Dependency.hs index f3af93e7..0479f980 100644 --- a/fficxx/src/FFICXX/Generate/Dependency.hs +++ b/fficxx/src/FFICXX/Generate/Dependency.hs @@ -97,6 +97,7 @@ extractClassFromType :: Types -> [Either TemplateClass Class] extractClassFromType Void = [] extractClassFromType SelfType = [] extractClassFromType (CT _ _) = [] +extractClassFromType (CPT (CPTEnum _) _) = [] extractClassFromType (CPT (CPTClass c) _) = [Right c] extractClassFromType (CPT (CPTClassRef c) _) = [Right c] extractClassFromType (CPT (CPTClassCopy c) _) = [Right c] diff --git a/fficxx/src/FFICXX/Generate/Name.hs b/fficxx/src/FFICXX/Generate/Name.hs index 6e443914..c7eb6aee 100644 --- a/fficxx/src/FFICXX/Generate/Name.hs +++ b/fficxx/src/FFICXX/Generate/Name.hs @@ -11,6 +11,7 @@ import FFICXX.Generate.Type.Class Arg (..), Class (..), ClassAlias (caFFIName, caHaskellName), + EnumType (..), Function (..), TLOrdinary (..), TLTemplate (..), @@ -25,16 +26,18 @@ import FFICXX.Generate.Type.Module ( ClassSubmoduleType (..), TemplateClassSubmoduleType (..), ) -import FFICXX.Generate.Util (firstLower, toLowers) +import FFICXX.Generate.Util (firstLower, firstUpper, toLowers) import System.FilePath ((<.>)) hsFrontNameForTopLevel :: TopLevel -> String hsFrontNameForTopLevel tfn = - let (x : xs) = case tfn of + let ys = case tfn of TLOrdinary TopLevelFunction {..} -> fromMaybe toplevelfunc_name toplevelfunc_alias TLOrdinary TopLevelVariable {..} -> fromMaybe toplevelvar_name toplevelvar_alias TLTemplate TopLevelTemplateFunction {..} -> topleveltfunc_name - in toLower x : xs + in case ys of + x : xs -> toLower x : xs + [] -> [] typeclassName :: Class -> String typeclassName c = 'I' : fst (hsClassName c) @@ -72,6 +75,12 @@ existConstructorName c = 'E' : (fst . hsClassName) c ffiClassName :: Class -> String ffiClassName c = maybe (class_name c) caFFIName (class_alias c) +enumDataTypeName :: EnumType -> String +enumDataTypeName = firstUpper . enum_name + +enumDataConstructorNames :: EnumType -> [String] +enumDataConstructorNames = map firstUpper . enum_cases + hscFuncName :: Class -> Function -> String hscFuncName c f = "c_" @@ -81,8 +90,9 @@ hscFuncName c f = hsFuncName :: Class -> Function -> String hsFuncName c f = - let (x : xs) = aliasedFuncName c f - in (toLower x) : xs + case aliasedFuncName c f of + x : xs -> toLower x : xs + [] -> [] aliasedFuncName :: Class -> Function -> String aliasedFuncName c f = diff --git a/fficxx/src/FFICXX/Generate/Type/Cabal.hs b/fficxx/src/FFICXX/Generate/Type/Cabal.hs index c0a8f42f..2f938a6d 100644 --- a/fficxx/src/FFICXX/Generate/Type/Cabal.hs +++ b/fficxx/src/FFICXX/Generate/Type/Cabal.hs @@ -13,9 +13,21 @@ import Data.Aeson.Types (fieldLabelModifier) import Data.Text (Text) import GHC.Generics (Generic) -data AddCInc = AddCInc FilePath String +-- | additionally embedded include files +data AddCInc + = AddCInc + FilePath + -- ^ target file path + String + -- ^ content -data AddCSrc = AddCSrc FilePath String +-- | additionally embedded C/C++ source files +data AddCSrc + = AddCSrc + FilePath + -- ^ target file path + String + -- ^ content -- TODO: change String to Text newtype CabalName = CabalName {unCabalName :: String} diff --git a/fficxx/src/FFICXX/Generate/Type/Class.hs b/fficxx/src/FFICXX/Generate/Type/Class.hs index abe6ce1e..aa1f7fcd 100644 --- a/fficxx/src/FFICXX/Generate/Type/Class.hs +++ b/fficxx/src/FFICXX/Generate/Type/Class.hs @@ -51,14 +51,23 @@ data CTypes | CTUInt64 | CTVoidStar | CTString - | CEnum CTypes String | CPointer CTypes | CRef CTypes deriving (Show) +-- TODO: Enum needs to be handled in the same way as Class with ModuleUnit +data EnumType = EnumType + { enum_name :: String, + enum_cases :: [String], + -- TODO: this must go to ModuleUnitImports + enum_header :: String + } + deriving (Show) + -- | C++ types data CPPTypes - = CPTClass Class + = CPTEnum EnumType + | CPTClass Class | CPTClassRef Class | CPTClassCopy Class | CPTClassMove Class diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index b4b62d74..f972191b 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -2,7 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} module FFICXX.Generate.Util.GHCExactPrint - ( -- * module + ( -- * DeclGroup + DeclGroup (..), + + -- * utilities + exactPrint, + + -- * module mkModule, mkModuleE, @@ -45,6 +51,7 @@ module FFICXX.Generate.Util.GHCExactPrint mkFun, mkFun_, mkFunSig, + mkBind, mkBind1, mkBind1_, @@ -75,6 +82,7 @@ module FFICXX.Generate.Util.GHCExactPrint letE, listE, mkVar, + mkVarWithComment, op, par, strE, @@ -95,14 +103,16 @@ module FFICXX.Generate.Util.GHCExactPrint typeBracket, tySplice, - -- * utility - exactPrint, + -- * doc + dummyComment, + comment, ) where import Data.Foldable (toList) import Data.List (foldl') import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Data.String (IsString (fromString)) import GHC.Data.Bag (emptyBag, listToBag) import GHC.Hs @@ -111,6 +121,10 @@ import GHC.Hs EpAnnHsCase (..), GhcPs, GrhsAnn (..), + HsDocString (MultiLineDocString), + HsDocStringChunk (..), + HsDocStringDecorator (HsDocStringNext), + WithHsDocIdentifiers (..), XImportDeclPass (..), XModulePs (..), ) @@ -126,6 +140,7 @@ import GHC.Parser.Annotation AnnSortKey (..), DeltaPos (..), EpAnn (..), + EpAnnComments (EpaComments, EpaCommentsBalanced), EpaComment (..), EpaCommentTok (..), EpaLocation (..), @@ -185,6 +200,7 @@ import Language.Haskell.Syntax ConDecl (..), DataDefnCons (..), DerivClauseTys (..), + DocDecl (..), ExprLStmt, FamEqn (..), ForeignDecl (..), @@ -231,6 +247,7 @@ import Language.Haskell.Syntax ImportDeclQualifiedStyle (..), InstDecl (..), IsBootInterface (..), + LHsDecl, LHsExpr, LHsQTyVars (..), LIdP, @@ -252,6 +269,22 @@ import Language.Haskell.Syntax.Basic SrcStrictness (NoSrcStrict), ) +-- +-- DeclGroup +-- + +data DeclGroup + = DeclGroup [HsDecl GhcPs] + | Comment String + +-- +-- utilities +-- + +-- | exact print +exactPrint :: (Exact.ExactPrint ast) => ast -> String +exactPrint = Exact.exactPrint . Exact.makeDeltaAst + mkDeltaPos :: Int -> DeltaPos mkDeltaPos nLines | nLines < -1 = error "mkDeltaPos: cannot go backward further" @@ -284,6 +317,10 @@ mkRelSrcSpanAnn :: Int -> ann -> SrcAnn ann mkRelSrcSpanAnn nLines ann = SrcSpanAnn (mkRelEpAnn nLines ann) defSrcSpan +mkRelSrcSpanAnn' :: DeltaPos -> ann -> SrcAnn ann +mkRelSrcSpanAnn' delta ann = + SrcSpanAnn (mkRelEpAnn' delta ann) defSrcSpan + defSrcSpan :: SrcSpan defSrcSpan = spn where @@ -333,6 +370,18 @@ mkL' delta = L anno' a' = a {anchor_op = MovedAnchor delta} anno' = SrcSpanAnn (EpAnn a' (AnnListItem []) emptyComments) defSrcSpan +formatDeclGroup :: DeclGroup -> [LHsDecl GhcPs] +formatDeclGroup (DeclGroup decls) = paragraphLines decls +formatDeclGroup (Comment str) = + [L (SrcSpanAnn epann defSrcSpan) (DocD noExtField dummyComment)] + where + epann = EpAnn (mkRelAnchor (-1)) noAnnListItem lcmts + lcmts = EpaComments [L (mkRelAnchor 2) cmt] + cmt = + EpaComment + (EpaLineComment str) + defRealSrcSpan + -- -- Modules -- @@ -342,8 +391,11 @@ mkModule :: String -> -- | Pragmas [String] -> + -- | imports [ImportDecl GhcPs] -> - [HsDecl GhcPs] -> + -- | body of the module (separated in groups) + [DeclGroup] -> + -- | resultant HsModule HsModule GhcPs mkModule name pragmas idecls decls = mkModuleE name pragmas Nothing idecls decls @@ -356,9 +408,11 @@ mkModuleE :: Maybe [IE GhcPs] -> -- | imports [ImportDecl GhcPs] -> - [HsDecl GhcPs] -> + -- | body of the module (separated in groups) + [DeclGroup] -> + -- | resultant HsModule HsModule GhcPs -mkModuleE name pragmas mies idecls decls = +mkModuleE name pragmas mies idecls declss = HsModule { hsmodExt = XModulePs @@ -371,9 +425,10 @@ mkModuleE name pragmas mies idecls decls = hsmodExports = fmap (L (mkRelSrcSpanAnn (-1) annExport) . tupleAnn) mies, hsmodImports = paragraphLines idecls, - hsmodDecls = paragraphLines decls + hsmodDecls = ldecls } where + ldecls = concatMap formatDeclGroup declss modName = ModuleName (fromString name) pragmaComments = let ls = @@ -670,9 +725,11 @@ mkData :: mkData name tbinds cdecls deriv = DataDecl (mkRelEpAnn (-1) annos) (mkLIdP 0 name) qty Prefix dfn where - annos = - [ AddEpAnn AnnData (mkEpaDelta (-1)) - ] + annData = AddEpAnn AnnData (mkEpaDelta (-1)) + annEqual = AddEpAnn AnnEqual (mkEpaDelta 0) + annos + | null cdecls = [annData] + | otherwise = [annData, annEqual] qty = HsQTvs noExtField $ fmap (mkL 0) tbinds dfn = HsDataDefn @@ -680,7 +737,9 @@ mkData name tbinds cdecls deriv = dd_ctxt = Nothing, dd_cType = Nothing, dd_kindSig = Nothing, - dd_cons = DataTypeCons False (fmap (mkL (-1)) cdecls), + dd_cons = + let loc = EpaDelta (DifferentLine 1 2) [] + in DataTypeCons False (listSep' loc AddVbarAnn cdecls), dd_derivs = deriv } @@ -813,6 +872,25 @@ mkFunSig fname typ = (HsOuterImplicit noExtField) (mkL (-1) typ) +mkBind :: + DeltaPos -> + String -> + [([Pat GhcPs], HsExpr GhcPs, HsLocalBinds GhcPs)] -> + HsBind GhcPs +mkBind delta fname matches = + FunBind noExtField lid payload + where + id' = unqual (mkVarOcc fname) + lid = L (mkRelSrcSpanAnn (-1) (NameAnnTrailing [])) id' + matches' = + fmap + ( \(pats, rhs, bnds) -> + mkMatch (FunRhs lid Prefix NoSrcStrict) pats rhs bnds + ) + matches + lmatches' = fmap (L (mkRelSrcSpanAnn' delta noAnnListItem)) matches' -- paragraphLines' (SameLine 0) matches' + payload = MG FromSource (L (mkRelSrcSpanAnn (-1) noAnnList) lmatches') + mkBind1 :: String -> [Pat GhcPs] -> @@ -835,18 +913,25 @@ mkBind1_ :: HsBind GhcPs mkBind1_ fname pats rhs = mkBind1 fname pats rhs (EmptyLocalBinds noExtField) -listSep :: (EpaLocation -> TrailingAnn) -> [a] -> [GenLocated SrcSpanAnnA a] -listSep _ [] = [] -listSep _ (x : []) = [mkL (-1) x] -listSep sep xs = +listSep' :: + EpaLocation -> + (EpaLocation -> TrailingAnn) -> + [a] -> + [GenLocated SrcSpanAnnA a] +listSep' _ _ [] = [] +listSep' _ _ (x : []) = [mkL (-1) x] +listSep' loc sep xs = let xs' = init xs lastX = last xs xs'' = fmap - (L (mkRelSrcSpanAnn 0 (AnnListItem [sep (mkEpaDelta (-1))]))) + (L (mkRelSrcSpanAnn 0 (AnnListItem [sep loc]))) xs' in (xs'' ++ [mkL 0 lastX]) +listSep :: (EpaLocation -> TrailingAnn) -> [a] -> [GenLocated SrcSpanAnnA a] +listSep = listSep' (mkEpaDelta (-1)) + tupleAnn :: [a] -> [GenLocated SrcSpanAnnA a] tupleAnn = listSep AddCommaAnn @@ -1181,6 +1266,19 @@ mkVar :: String -> HsExpr GhcPs mkVar name = HsVar noExtField (mkLIdP (-1) name) +mkVarWithComment :: String -> String -> HsExpr GhcPs +mkVarWithComment name str = + HsVar noExtField (L ann id') + where + id' = unqual (mkVarOcc name) + cmt = + EpaComment + (EpaLineComment str) + defRealSrcSpan + lcmts = EpaComments [L (mkRelAnchor 0) cmt] + ann = + SrcSpanAnn (EpAnn (mkRelAnchor (-1)) (NameAnnTrailing []) lcmts) defSrcSpan + op :: String -> HsExpr GhcPs op = mkVar @@ -1296,9 +1394,18 @@ tySplice :: HsUntypedSplice GhcPs -> HsType GhcPs tySplice sp = HsSpliceTy noExtField sp -- --- utilities +-- doc -- --- | exact print -exactPrint :: (Exact.ExactPrint ast) => ast -> String -exactPrint = Exact.exactPrint . Exact.makeDeltaAst +-- DocCommentNext content with dummy contents +dummyComment :: DocDecl GhcPs +dummyComment = + DocCommentNext (L defSrcSpan (WithHsDocIdentifiers str [])) + where + str = + MultiLineDocString + HsDocStringNext + (NE.singleton (L defSrcSpan (HsDocStringChunk ""))) + +comment :: String -> DeclGroup +comment = Comment diff --git a/stdcxx-gen/Gen.hs b/stdcxx-gen/Gen.hs index 49aa078d..c563c681 100644 --- a/stdcxx-gen/Gen.hs +++ b/stdcxx-gen/Gen.hs @@ -30,6 +30,7 @@ import FFICXX.Generate.Type.Class ( Arg (..), Class (..), ClassAlias (..), + EnumType (..), Form (FormNested, FormSimple), Function (..), OpExp (..), @@ -125,6 +126,9 @@ classes = string ] +enums :: [EnumType] +enums = [] + toplevels :: [TopLevel] toplevels = [] @@ -351,6 +355,7 @@ main = do sbcModUnitMap = ModuleUnitMap (HM.fromList headers), sbcCabal = cabal, sbcClasses = classes, + sbcEnums = enums, sbcTopLevels = toplevels, sbcTemplates = templates, sbcExtraLibs = ["stdc++"], From 3be050d3775ab0dcae6e63fc52455be6e4ca5d56 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Mon, 14 Aug 2023 18:04:32 -0700 Subject: [PATCH 13/19] missing Castable instance for Ptr CBool and Ptr CFloat (#223) * missing Castable instance for Ptr CBool * missing Castable (Ptr CFloat) (Ptr CFloat) --- fficxx-runtime/src/FFICXX/Runtime/Cast.hs | 8 ++++++++ fficxx/src/FFICXX/Generate/Builder.hs | 1 - 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/fficxx-runtime/src/FFICXX/Runtime/Cast.hs b/fficxx-runtime/src/FFICXX/Runtime/Cast.hs index ef0ba2e1..bb7d6508 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/Cast.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/Cast.hs @@ -297,6 +297,10 @@ instance Castable Word64 Word64 where cast x f = f x uncast x f = f x +instance Castable (Ptr CBool) (Ptr CBool) where + cast x f = f x + uncast x f = f x + instance Castable (Ptr CInt) (Ptr CInt) where cast x f = f x uncast x f = f x @@ -317,6 +321,10 @@ instance Castable (Ptr CLong) (Ptr CLong) where cast x f = f x uncast x f = f x +instance Castable (Ptr CFloat) (Ptr CFloat) where + cast x f = f x + uncast x f = f x + instance Castable (Ptr CDouble) (Ptr CDouble) where cast x f = f x uncast x f = f x diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index a2d8c724..d58d3bbb 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -157,7 +157,6 @@ simpleBuilder cfg sbc = do for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt) -- putStrLn "Generating Enum.hsc" - debugExactPrint (C.buildEnumHsc mempty (topLevelMod <> ".Enum") enums) gen (topLevelMod <.> "Enum" <.> "hsc") (exactPrint (C.buildEnumHsc mempty (topLevelMod <> ".Enum") enums)) From 59deb27555cfbb46717c658598b29321bb04af2e Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Tue, 15 Aug 2023 23:18:14 -0700 Subject: [PATCH 14/19] Bug fix: import Foreign.C instead of Foreign.C.Types (for CString) (#226) --- fficxx/src/FFICXX/Generate/ContentMaker.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 50c6be01..600b095b 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -547,7 +547,7 @@ buildTemplateHs m = where t = tcihTClass $ tcmTCIH m imports = - [ Ex.mkImport "Foreign.C.Types", + [ Ex.mkImport "Foreign.C", Ex.mkImport "Foreign.Ptr", Ex.mkImport "FFICXX.Runtime.Cast" ] @@ -562,7 +562,7 @@ buildTHHs m = ( [ Ex.mkImport "Data.Char", Ex.mkImport "Data.List", Ex.mkImport "Data.Monoid", - Ex.mkImport "Foreign.C.Types", + Ex.mkImport "Foreign.C", Ex.mkImport "Foreign.Ptr", Ex.mkImport "Language.Haskell.TH", Ex.mkImport "Language.Haskell.TH.Syntax", @@ -681,7 +681,7 @@ buildTopLevelTemplateHs modname tih = ) tfns pkgImports = - [ Ex.mkImport "Foreign.C.Types", + [ Ex.mkImport "Foreign.C", Ex.mkImport "Foreign.Ptr", Ex.mkImport "FFICXX.Runtime.Cast" ] @@ -716,7 +716,7 @@ buildTopLevelTHHs modname tih = [ Ex.mkImport "Data.Char", Ex.mkImport "Data.List", Ex.mkImport "Data.Monoid", - Ex.mkImport "Foreign.C.Types", + Ex.mkImport "Foreign.C", Ex.mkImport "Foreign.Ptr", Ex.mkImport "Language.Haskell.TH", Ex.mkImport "Language.Haskell.TH.Syntax", From 7c06b4bca1d574cb10ddc3bfadb73462febfb19a Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Wed, 16 Aug 2023 00:14:39 -0700 Subject: [PATCH 15/19] bug fix. TemplateParamPointer for primitive type T = T* (#227) --- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 2008ff95..0a73d9f7 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -510,7 +510,7 @@ tmplArgToCTypVar _ (Arg (TemplateAppMove _) v) = (R.CTStar R.CTVoid, R.sname v) tmplArgToCTypVar _ (Arg (TemplateType _) v) = (R.CTStar R.CTVoid, R.sname v) tmplArgToCTypVar CPrim (Arg (TemplateParam t) v) = (R.CTSimple (R.sname t), R.sname v) tmplArgToCTypVar NonCPrim (Arg (TemplateParam t) v) = (R.CTSimple (R.CName [R.NamePart t, R.NamePart "_p"]), R.sname v) -tmplArgToCTypVar CPrim (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.sname t), R.sname v) +tmplArgToCTypVar CPrim (Arg (TemplateParamPointer t) v) = (R.CTStar (R.CTSimple (R.sname t)), R.sname v) tmplArgToCTypVar NonCPrim (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.CName [R.NamePart t, R.NamePart "_p"]), R.sname v) tmplArgToCTypVar _ _ = error "tmplArgToCTypVar: undefined" From 801986625e644c46ee0c57883fe7931f02defcea Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Sat, 26 Aug 2023 16:52:16 -0700 Subject: [PATCH 16/19] handle missing case of CPTEnum. (#228) Now int to enum type is explicitly casted. so on Haskell side, enum argument is still CInt, but on C++ side, it's explicitly casted by cast operator: (enum_type) --- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 0a73d9f7..3dec48d6 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -20,6 +20,7 @@ import FFICXX.Generate.Type.Class CPPTypes (..), CTypes (..), Class (..), + EnumType (enum_name), Form (..), Function (..), IsConst (Const, NoConst), @@ -293,6 +294,8 @@ argToCTypVar (Arg (CT ctyp isconst) varname) = (ctypToCType ctyp isconst, R.sname varname) argToCTypVar (Arg SelfType varname) = (R.CTSimple (R.CName [R.NamePart "Type", R.NamePart "_p"]), R.sname varname) +argToCTypVar (Arg (CPT (CPTEnum _e) _isconst) varname) = + (ctypToCType CTInt NoConst, R.sname varname) argToCTypVar (Arg (CPT (CPTClass c) isconst) varname) = case isconst of Const -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname) @@ -356,6 +359,8 @@ c2Cxx :: Types -> R.CExp Identity -> R.CExp Identity c2Cxx t e = case t of CT (CRef _) _ -> R.CStar e + CPT (CPTEnum en) _ -> + R.CCast (R.CTVerbatim (enum_name en)) e CPT (CPTClass c) _ -> R.CTApp (R.sname "from_nonconst_to_nonconst") @@ -840,7 +845,8 @@ extractArgRetTypes mc isvirtual (CFunSig args ret) = case typ of SelfType -> return (Ex.mkTVar "a") CT CTString Const -> addstring - CT _ _ -> return $ cxx2HsType Nothing typ + CT _ _ -> pure $ cxx2HsType Nothing typ + CPT (CPTEnum _e) _ -> pure $ cxx2HsType Nothing (CT CTInt NoConst) CPT (CPTClass c') _ -> addclass c' CPT (CPTClassRef c') _ -> addclass c' CPT (CPTClassCopy c') _ -> addclass c' @@ -978,6 +984,7 @@ hsFFIFunType msc (CFunSig args ret) = -- hsargtype :: Types -> HsType GhcPs hsargtype (CT ctype _) = c2HsType ctype + hsargtype (CPT (CPTEnum _) _) = c2HsType CTInt hsargtype (CPT (CPTClass d) _) = Ex.tyapp Ex.tyPtr (Ex.tycon rawname) where rawname = snd (hsClassName d) From 33e73b5df3cc87e0bbf719a841dc1ec3a07d78c5 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Sun, 27 Aug 2023 20:28:05 -0700 Subject: [PATCH 17/19] FFI safety is now explicitly given (#229) User should now specify unsafe/safe/interruptible explicitly. constructors and destructors are always unsafe (this should be taken granted. C++ library should not call Haskell back inside constructor/destructors). Accessor functions (getter/setter) are also unsafe. On the other hand, calling an instance of std::function (which is hard-coded in FFICXX.Runtime.Function.TH) should be unconditionally safe. * unsafe testing * introduce C FFI Safety * ordinary function safety is handled. * Safety in fficxx-runtime * template haskell gen now handles Safety * Add Safety parameter in TFun. and update stdcxx * update examples with Safety parameter * upgrade template TH code generation with FFISafety * calling std::function should be safe! --- fficxx-multipkg-test/template-dep/Gen.hs | 7 ++- fficxx-multipkg-test/template-member/Gen.hs | 31 ++++++------ fficxx-multipkg-test/template-toplevel/Gen.hs | 15 +++--- fficxx-runtime/fficxx-runtime.cabal | 5 +- .../src/FFICXX/Runtime/Function/TH.hs | 17 ++++--- fficxx-runtime/src/FFICXX/Runtime/TH.hs | 15 ++++-- fficxx-runtime/src/FFICXX/Runtime/Types.hs | 7 +++ fficxx-test/fficxx-test.cabal | 2 +- fficxx/src/FFICXX/Generate/Builder.hs | 2 +- fficxx/src/FFICXX/Generate/Code/HsEnum.hs | 4 +- fficxx/src/FFICXX/Generate/Code/HsFFI.hs | 31 ++++++++---- .../FFICXX/Generate/Code/HsImplementation.hs | 15 ++++-- fficxx/src/FFICXX/Generate/Code/HsTH.hs | 18 +++++-- fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs | 15 +++--- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 25 ++++++---- fficxx/src/FFICXX/Generate/ContentMaker.hs | 12 +++-- fficxx/src/FFICXX/Generate/Dependency.hs | 10 ++-- fficxx/src/FFICXX/Generate/Name.hs | 16 +++---- fficxx/src/FFICXX/Generate/Type/Class.hs | 47 +++++++++++++------ .../src/FFICXX/Generate/Util/GHCExactPrint.hs | 30 +++++++----- stdcxx-gen/Gen.hs | 46 +++++++++++------- 21 files changed, 235 insertions(+), 135 deletions(-) create mode 100644 fficxx-runtime/src/FFICXX/Runtime/Types.hs diff --git a/fficxx-multipkg-test/template-dep/Gen.hs b/fficxx-multipkg-test/template-dep/Gen.hs index 7c4ef7ac..81bf3e6f 100644 --- a/fficxx-multipkg-test/template-dep/Gen.hs +++ b/fficxx-multipkg-test/template-dep/Gen.hs @@ -58,6 +58,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.FilePath (()) @@ -104,7 +105,8 @@ tT1 cabal = tfun_new_alias = Nothing }, TFun - { tfun_ret = Void, + { tfun_safety = FFIUnsafe, + tfun_ret = Void, tfun_name = "method", tfun_oname = "method", tfun_args = [] @@ -126,7 +128,8 @@ tT2 cabal = tfun_new_alias = Nothing }, TFun - { tfun_ret = Void, + { tfun_safety = FFIUnsafe, + tfun_ret = Void, tfun_name = "callT1", tfun_oname = "callT1", tfun_args = diff --git a/fficxx-multipkg-test/template-member/Gen.hs b/fficxx-multipkg-test/template-member/Gen.hs index 4e1d474a..2078fe81 100644 --- a/fficxx-multipkg-test/template-member/Gen.hs +++ b/fficxx-multipkg-test/template-member/Gen.hs @@ -58,6 +58,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.FilePath (()) @@ -109,9 +110,9 @@ string = mempty (Just (ClassAlias {caHaskellName = "CppString", caFFIName = "string"})) [ Constructor [cstring "p"] Nothing, - NonVirtual cstring_ "c_str" [] Nothing, - NonVirtual (cppclassref_ string) "append" [cppclassref string "str"] Nothing, - NonVirtual (cppclassref_ string) "erase" [] Nothing + NonVirtual FFIUnsafe cstring_ "c_str" [] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "append" [cppclassref string "str"] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "erase" [] Nothing ] [] [] @@ -125,10 +126,10 @@ t_vector = (FormSimple "std::vector") ["tp1"] [ TFunNew [] Nothing, - TFun void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], - TFun void_ "pop_back" "pop_back" [], - TFun (TemplateParam "tp1") "at" "at" [int "n"], - TFun int_ "size" "size" [], + TFun FFIUnsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], + TFun FFIUnsafe void_ "pop_back" "pop_back" [], + TFun FFIUnsafe (TemplateParam "tp1") "at" "at" [int "n"], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -142,9 +143,9 @@ t_unique_ptr = ["tp1"] [ TFunNew [] (Just "newUniquePtr0"), TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing, - TFun (TemplateParamPointer "tp1") "get" "get" [], - TFun (TemplateParamPointer "tp1") "release" "release" [], - TFun void_ "reset" "reset" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "get" "get" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "release" "release" [], + TFun FFIUnsafe void_ "reset" "reset" [], TFunDelete ] [] @@ -190,14 +191,16 @@ classA cabal = class_vars = [], class_tmpl_funcs = [ TemplateMemberFunction - { tmf_params = ["tp1"], + { tmf_safety = FFIUnsafe, + tmf_params = ["tp1"], tmf_ret = void_, tmf_name = "method", tmf_args = [Arg (TemplateParamPointer "tp1") "x"], tmf_alias = Nothing }, TemplateMemberFunction - { tmf_params = ["tp1"], + { tmf_safety = FFIUnsafe, + tmf_params = ["tp1"], tmf_ret = void_, tmf_name = "method2", tmf_args = @@ -227,7 +230,7 @@ classT1 cabal = class_alias = Nothing, class_funcs = [ Constructor [] Nothing, - NonVirtual void_ "print" [] Nothing + NonVirtual FFIUnsafe void_ "print" [] Nothing ], class_vars = [], class_tmpl_funcs = [], @@ -244,7 +247,7 @@ classT2 cabal = class_alias = Nothing, class_funcs = [ Constructor [] Nothing, - NonVirtual void_ "print" [] Nothing + NonVirtual FFIUnsafe void_ "print" [] Nothing ], class_vars = [], class_tmpl_funcs = [], diff --git a/fficxx-multipkg-test/template-toplevel/Gen.hs b/fficxx-multipkg-test/template-toplevel/Gen.hs index 0a87d8ce..fe8b74a2 100644 --- a/fficxx-multipkg-test/template-toplevel/Gen.hs +++ b/fficxx-multipkg-test/template-toplevel/Gen.hs @@ -58,6 +58,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.FilePath (()) @@ -111,10 +112,10 @@ t_vector = (FormSimple "std::vector") ["tp1"] [ TFunNew [] Nothing, - TFun void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], - TFun void_ "pop_back" "pop_back" [], - TFun (TemplateParam "tp1") "at" "at" [int "n"], - TFun int_ "size" "size" [], + TFun FFIUnsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], + TFun FFIUnsafe void_ "pop_back" "pop_back" [], + TFun FFIUnsafe (TemplateParam "tp1") "at" "at" [int "n"], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -155,14 +156,16 @@ toplevels :: [TopLevel] toplevels = [ TLOrdinary TopLevelFunction - { toplevelfunc_ret = Void, + { toplevelfunc_safety = FFIUnsafe, + toplevelfunc_ret = Void, toplevelfunc_name = "ordinary", toplevelfunc_args = [], toplevelfunc_alias = Nothing }, TLTemplate ( TopLevelTemplateFunction - { topleveltfunc_params = ["t1"], + { topleveltfunc_safety = FFIUnsafe, + topleveltfunc_params = ["t1"], topleveltfunc_ret = TemplateAppMove (TemplateAppInfo t_vector [TArg_TypeParam "t1"] "std::vector"), topleveltfunc_name = "return_vector", diff --git a/fficxx-runtime/fficxx-runtime.cabal b/fficxx-runtime/fficxx-runtime.cabal index 8f0f4c9e..2fb7b031 100644 --- a/fficxx-runtime/fficxx-runtime.cabal +++ b/fficxx-runtime/fficxx-runtime.cabal @@ -9,7 +9,7 @@ License-file: LICENSE Author: Ian-Woo Kim Maintainer: Ian-Woo Kim Build-Type: Simple -Tested-With: GHC == 9.2.7 || == 9.4.5 || == 9.6.2 +Tested-With: GHC == 9.6.2 Category: FFI Tools Extra-Source-Files: ChangeLog.md @@ -31,8 +31,7 @@ Library FFICXX.Runtime.Function.Template FFICXX.Runtime.Function.TH FFICXX.Runtime.TH - - + FFICXX.Runtime.Types Include-dirs: csrc Install-includes: MacroPatternMatch.h Function.h diff --git a/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs b/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs index 47607f47..565a833c 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs @@ -10,11 +10,13 @@ import FFICXX.Runtime.Function.Template (Function) import FFICXX.Runtime.TH ( FunctionParamInfo (..), con, + mkDelete, mkInstance, mkMember, mkNew, mkTFunc, ) +import FFICXX.Runtime.Types (FFISafety (..)) import Foreign.Ptr (FunPtr) import Language.Haskell.TH (forImpD, safe) import Language.Haskell.TH.Syntax @@ -45,15 +47,15 @@ mkWrapper (typ, suffix) = t_newFunction :: Type -> String -> Q Exp t_newFunction typ suffix = - mkTFunc (typ, suffix, \n -> "Function_new_" <> n, tyf) + mkTFunc FFIUnsafe (typ, suffix, \n -> "Function_new_" <> n, tyf) where tyf _n = let t = pure typ in [t|FunPtr $(t) -> IO (Function $(t))|] -t_call :: Type -> String -> Q Exp -t_call typ suffix = - mkTFunc (typ, suffix, \n -> "Function_call_" <> n, tyf) +t_call :: FFISafety -> Type -> String -> Q Exp +t_call safety typ suffix = + mkTFunc safety (typ, suffix, \n -> "Function_call_" <> n, tyf) where tyf _n = let t = pure typ @@ -61,7 +63,7 @@ t_call typ suffix = t_deleteFunction :: Type -> String -> Q Exp t_deleteFunction typ suffix = - mkTFunc (typ, suffix, \n -> "Function_delete_" <> n, tyf) + mkTFunc FFIUnsafe (typ, suffix, \n -> "Function_delete_" <> n, tyf) where tyf _n = let t = pure typ @@ -73,8 +75,9 @@ genFunctionInstanceFor qtyp param = let suffix = fpinfoSuffix param typ <- qtyp f1 <- mkNew "newFunction" t_newFunction typ suffix - f2 <- mkMember "call" t_call typ suffix - f3 <- mkMember "deleteFunction" t_deleteFunction typ suffix + -- NOTE: The indirected function call should be safe. + f2 <- mkMember "call" (t_call FFISafe) typ suffix + f3 <- mkDelete "deleteFunction" t_deleteFunction typ suffix wrap <- mkWrapper (typ, suffix) addModFinalizer ( addForeignSource diff --git a/fficxx-runtime/src/FFICXX/Runtime/TH.hs b/fficxx-runtime/src/FFICXX/Runtime/TH.hs index f28ee7c9..c86aef8a 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/TH.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/TH.hs @@ -2,9 +2,9 @@ module FFICXX.Runtime.TH where --- import FFICXX.Runtime.CodeGen.Cxx (HeaderName, Namespace) -import Language.Haskell.TH (forImpD, safe, varE) +import FFICXX.Runtime.Types (FFISafety (..)) +import Language.Haskell.TH (forImpD, interruptible, safe, unsafe, varE) import Language.Haskell.TH.Syntax ( Body (NormalB), Callconv (CCall), @@ -54,13 +54,18 @@ con = ConT . mkNameS mkInstance :: Cxt -> Type -> [Dec] -> Dec mkInstance = InstanceD Nothing -mkTFunc :: (types, String, String -> String, types -> Q Type) -> Q Exp -mkTFunc (typs, suffix, nf, tyf) = +mkTFunc :: FFISafety -> (types, String, String -> String, types -> Q Type) -> Q Exp +mkTFunc safety (typs, suffix, nf, tyf) = do let fn = nf suffix let fn' = "c_" <> fn n <- newName fn' - d <- forImpD CCall safe fn n (tyf typs) + let safety_modifier = + case safety of + FFIUnsafe -> unsafe + FFISafe -> safe + FFIInterruptible -> interruptible + d <- forImpD CCall safety_modifier fn n (tyf typs) addTopDecls [d] [|$(varE n)|] diff --git a/fficxx-runtime/src/FFICXX/Runtime/Types.hs b/fficxx-runtime/src/FFICXX/Runtime/Types.hs new file mode 100644 index 00000000..eacff8df --- /dev/null +++ b/fficxx-runtime/src/FFICXX/Runtime/Types.hs @@ -0,0 +1,7 @@ +module FFICXX.Runtime.Types + ( FFISafety (..), + ) +where + +data FFISafety = FFIUnsafe | FFISafe | FFIInterruptible + deriving (Show) diff --git a/fficxx-test/fficxx-test.cabal b/fficxx-test/fficxx-test.cabal index 4362c0ca..9fbb059d 100644 --- a/fficxx-test/fficxx-test.cabal +++ b/fficxx-test/fficxx-test.cabal @@ -1,6 +1,6 @@ Cabal-Version: 3.0 Name: fficxx-test -Version: 0.7.0.1 +Version: 0.8.0.0 Synopsis: test for fficxx Description: test for fficxx (with stdcxx) License: BSD-2-Clause diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index d58d3bbb..a041578a 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/fficxx/src/FFICXX/Generate/Builder.hs @@ -159,7 +159,7 @@ simpleBuilder cfg sbc = do putStrLn "Generating Enum.hsc" gen (topLevelMod <.> "Enum" <.> "hsc") - (exactPrint (C.buildEnumHsc mempty (topLevelMod <> ".Enum") enums)) + (exactPrint (C.buildEnumHsc (topLevelMod <> ".Enum") enums)) -- putStrLn "Generating RawType.hs" for_ mods $ \m -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsEnum.hs b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs index 2a5e1b1d..3eaa690b 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsEnum.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs @@ -4,12 +4,10 @@ module FFICXX.Generate.Code.HsEnum ) where -import Control.Monad.Reader (Reader) import FFICXX.Generate.Name ( enumDataConstructorNames, enumDataTypeName, ) -import FFICXX.Generate.Type.Annotate (AnnotateMap) import FFICXX.Generate.Type.Class (EnumType (..)) import FFICXX.Generate.Util.GHCExactPrint ( DeclGroup, @@ -31,7 +29,7 @@ import FFICXX.Generate.Util.GHCExactPrint import GHC.Hs (GhcPs) import GHC.Parser.Annotation (DeltaPos (..)) import Language.Haskell.Syntax - ( HsDecl (DocD, TyClD), + ( HsDecl (TyClD), HsLocalBindsLR (..), noExtField, ) diff --git a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs index c27de5df..d21ded53 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs @@ -10,6 +10,7 @@ import FFICXX.Generate.Code.Primitive genericFuncArgs, genericFuncRet, hsFFIFunType, + toGHCSafety, ) import FFICXX.Generate.Dependency ( class_allparents, @@ -29,6 +30,7 @@ import FFICXX.Generate.Type.Class Selfness (NoSelf, Self), TLOrdinary (..), Variable (unVariable), + getFunSafety, isAbstractClass, isNewFunc, isStaticFunc, @@ -45,9 +47,8 @@ import FFICXX.Generate.Util.GHCExactPrint mkImport, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) -import GHC.Hs - ( GhcPs, - ) +import FFICXX.Runtime.Types (FFISafety (FFIUnsafe)) +import GHC.Hs (GhcPs) import Language.Haskell.Syntax ( ForeignDecl, ImportDecl, @@ -80,6 +81,7 @@ hsFFIClassFunc headerfilename c f = then Nothing else let hfile = unHdrName headerfilename + safety = getFunSafety f -- TODO: Make this a separate function cname = ffiClassName c <> "_" <> aliasedFuncName c f csig = CFunSig (genericFuncArgs f) (genericFuncRet f) @@ -87,7 +89,7 @@ hsFFIClassFunc headerfilename c f = if (isNewFunc f || isStaticFunc f) then hsFFIFunType (Just (NoSelf, c)) csig else hsFFIFunType (Just (Self, c)) csig - in Just (mkForImpCcall (hfile <> " " <> cname) (hscFuncName c f) typ) + in Just (mkForImpCcall (toGHCSafety safety) (hfile <> " " <> cname) (hscFuncName c f) typ) hsFFIAccessor :: Class -> Variable -> Accessor -> ForeignDecl GhcPs hsFFIAccessor c v a = @@ -97,7 +99,7 @@ hsFFIAccessor c v a = hsFFIFunType (Just (Self, c)) (accessorCFunSig (arg_type (unVariable v)) a) - in mkForImpCcall cname (hscAccessorName c v a) typ + in mkForImpCcall (toGHCSafety FFIUnsafe) cname (hscAccessorName c v a) typ -- import for FFI genImportInFFI :: ClassModule -> [ImportDecl GhcPs] @@ -108,12 +110,23 @@ genImportInFFI = fmap (mkImport . subModuleName) . cmImportedSubmodulesForFFI ---------------------------- genTopLevelFFI :: TopLevelImportHeader -> TLOrdinary -> ForeignDecl GhcPs -genTopLevelFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ +genTopLevelFFI header tfn = + mkForImpCcall (toGHCSafety safety) (hfilename <> " TopLevel_" <> fname) cfname typ where - (fname, args, ret) = + (safety, fname, args, ret) = case tfn of - TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret) - TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret) + TopLevelFunction {..} -> + ( toplevelfunc_safety, + fromMaybe toplevelfunc_name toplevelfunc_alias, + toplevelfunc_args, + toplevelfunc_ret + ) + TopLevelVariable {..} -> + ( FFIUnsafe, + fromMaybe toplevelvar_name toplevelvar_alias, + [], + toplevelvar_ret + ) hfilename = tihHeaderFileName header <.> "h" -- TODO: This must be exposed as a top-level function cfname = "c_" <> toLowers fname diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs index 0e536146..651abe87 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs @@ -94,6 +94,7 @@ import FFICXX.Generate.Util.GHCExactPrint ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) import Language.Haskell.Syntax (HsDecl, ImportDecl) @@ -186,12 +187,18 @@ genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs bstmts | otherwise = [pTuple (fmap p tvars)] lit' = strE (hsTemplateMemberFunctionName c f <> "_") lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + safety = + case tmf_safety f of + FFIUnsafe -> "FFIUnsafe" + FFISafe -> "FFISafe" + FFIInterruptible -> "FFIInterruptible" rhs = app (v "mkTFunc") $ - let typs - | nparams == 1 = fmap v tvars - | otherwise = [tupleE (map v tvars)] - in tupleE (typs ++ [v "suffix", lam, v "tyf"]) + app (v safety) $ + let typs + | nparams == 1 = fmap v tvars + | otherwise = [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = functionSignatureTMF c f tassgns = fmap diff --git a/fficxx/src/FFICXX/Generate/Code/HsTH.hs b/fficxx/src/FFICXX/Generate/Code/HsTH.hs index d48c7cf7..61d35e24 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTH.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTH.hs @@ -34,6 +34,7 @@ import FFICXX.Generate.Type.Class TemplateFunction (..), Types (Void), Variable (..), + getTFunSafety, ) import FFICXX.Generate.Type.Module ( TemplateClassImportHeader (..), @@ -78,6 +79,7 @@ import FFICXX.Generate.Util.GHCExactPrint import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) import Language.Haskell.Syntax ( HsDecl, @@ -111,10 +113,16 @@ genTmplImplementation t = nc = ffiTmplFuncName f lit' = strE (prefix <> "_" <> nc) lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + safety = + case getTFunSafety f of + FFIUnsafe -> "FFIUnsafe" + FFISafe -> "FFISafe" + FFIInterruptible -> "FFIInterruptible" rhs = app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] - in tupleE (typs ++ [v "suffix", lam, v "tyf"]) + app (v safety) $ + let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = functionSignatureTT t f tassgns = fmap @@ -221,14 +229,16 @@ genTmplInstance tcih = let Variable (Arg {..}) = vf f_g = TFun - { tfun_ret = arg_type, + { tfun_safety = FFIUnsafe, + tfun_ret = arg_type, tfun_name = tmplAccessorName vf Getter, tfun_oname = tmplAccessorName vf Getter, tfun_args = [] } f_s = TFun - { tfun_ret = Void, + { tfun_safety = FFIUnsafe, + tfun_ret = Void, tfun_name = tmplAccessorName vf Setter, tfun_oname = tmplAccessorName vf Setter, tfun_args = [Arg arg_type "value"] diff --git a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs index c4254d63..4a79059f 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs @@ -77,14 +77,12 @@ import FFICXX.Generate.Util.GHCExactPrint cxTuple, doE, eabs, - emodule, ethingall, evar, inapp, lamE, letE, listE, - mkBind1, mkBind1_, mkBindStmt, mkBodyStmt, @@ -106,7 +104,6 @@ import FFICXX.Generate.Util.GHCExactPrint strE, toLocalBinds, tupleE, - tyForall, tyParen, tySplice, tyTupleBoxed, @@ -115,13 +112,13 @@ import FFICXX.Generate.Util.GHCExactPrint tyfun, tylist, typeBracket, - unqual, valBinds, wildcard, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) import Language.Haskell.Syntax ( HsDecl (TyClD), @@ -276,10 +273,16 @@ genTLTemplateImplementation t = nc = topleveltfunc_name t lit' = strE (prefix <> "_" <> nc) lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + safety = + case topleveltfunc_safety t of + FFIUnsafe -> "FFIUnsafe" + FFISafe -> "FFISafe" + FFIInterruptible -> "FFIInterruptible" rhs = app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] - in tupleE (typs ++ [v "suffix", lam, v "tyf"]) + app (v safety) $ + let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = let e = error "genTLTemplateImplementation" spls = map (tySplice . parenSplice . mkVar) $ topleveltfunc_params t diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 3dec48d6..ce9855c6 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -39,12 +39,19 @@ import FFICXX.Generate.Type.Class import qualified FFICXX.Generate.Util.GHCExactPrint as Ex import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) +import qualified GHC.Types.ForeignCall as GHC (Safety (..)) import Language.Haskell.Syntax ( HsContext, HsType, ) +toGHCSafety :: FFISafety -> GHC.Safety +toGHCSafety FFIUnsafe = GHC.PlayRisky +toGHCSafety FFISafe = GHC.PlaySafe +toGHCSafety FFIInterruptible = GHC.PlayInterruptible + data CFunSig = CFunSig { cArgTypes :: [Arg], cRetType :: Types @@ -780,12 +787,12 @@ cxx2HsType4Tmpl _ _ _ (TemplateParam p) = Ex.tySplice . Ex.parenSplice . Ex.mkVa cxx2HsType4Tmpl _ _ _ (TemplateParamPointer p) = Ex.tySplice . Ex.parenSplice . Ex.mkVar $ p hsFuncXformer :: Function -> String -hsFuncXformer func@(Constructor _ _) = +hsFuncXformer func@(Constructor {}) = let len = length (genericFuncArgs func) in if len > 0 then "xform" <> show (len - 1) else "xformnull" -hsFuncXformer func@(Static _ _ _ _) = +hsFuncXformer func@(Static {}) = let len = length (genericFuncArgs func) in if len > 0 then "xform" <> show (len - 1) @@ -937,14 +944,16 @@ tmplAccessorToTFun v@(Variable (Arg {..})) a = case a of Getter -> TFun - { tfun_ret = arg_type, + { tfun_safety = FFIUnsafe, + tfun_ret = arg_type, tfun_name = tmplAccessorName v Getter, tfun_oname = tmplAccessorName v Getter, tfun_args = [] } Setter -> TFun - { tfun_ret = Void, + { tfun_safety = FFIUnsafe, + tfun_ret = Void, tfun_name = tmplAccessorName v Setter, tfun_oname = tmplAccessorName v Setter, tfun_args = [Arg arg_type "value"] @@ -1075,11 +1084,9 @@ hsFFIFunType msc (CFunSig args ret) = genericFuncRet :: Function -> Types genericFuncRet f = case f of - Constructor _ _ -> self_ - Virtual t _ _ _ -> t - NonVirtual t _ _ _ -> t - Static t _ _ _ -> t - Destructor _ -> void_ + Constructor {} -> self_ + Destructor {} -> void_ + _ -> func_ret f genericFuncArgs :: Function -> [Arg] genericFuncArgs (Destructor _) = [] diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 600b095b..6026fa7d 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -499,7 +499,8 @@ buildImplementationHs amap m = Ex.mkImport "System.IO.Unsafe", Ex.mkImport "FFICXX.Runtime.Cast", Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", -- for template member - Ex.mkImport "FFICXX.Runtime.TH" -- for template member + Ex.mkImport "FFICXX.Runtime.TH", -- for template member + Ex.mkImport "FFICXX.Runtime.Types" -- for template member ] <> genImportInImplementation m <> genExtraImport m @@ -567,7 +568,8 @@ buildTHHs m = Ex.mkImport "Language.Haskell.TH", Ex.mkImport "Language.Haskell.TH.Syntax", Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", - Ex.mkImport "FFICXX.Runtime.TH" + Ex.mkImport "FFICXX.Runtime.TH", + Ex.mkImport "FFICXX.Runtime.Types" ] <> imports ) @@ -595,11 +597,10 @@ buildModuleHs m = c = cihClass (cmCIH m) buildEnumHsc :: - AnnotateMap -> String -> [EnumType] -> HsModule GhcPs -buildEnumHsc amap modname enums = +buildEnumHsc modname enums = Ex.mkModuleE modname [] Nothing [] body where body = @@ -721,7 +722,8 @@ buildTopLevelTHHs modname tih = Ex.mkImport "Language.Haskell.TH", Ex.mkImport "Language.Haskell.TH.Syntax", Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", - Ex.mkImport "FFICXX.Runtime.TH" + Ex.mkImport "FFICXX.Runtime.TH", + Ex.mkImport "FFICXX.Runtime.Types" ] ++ concatMap genImportForTLTemplate tfns pkgBody = diff --git a/fficxx/src/FFICXX/Generate/Dependency.hs b/fficxx/src/FFICXX/Generate/Dependency.hs index 0479f980..9a1be453 100644 --- a/fficxx/src/FFICXX/Generate/Dependency.hs +++ b/fficxx/src/FFICXX/Generate/Dependency.hs @@ -155,23 +155,23 @@ data Dep4Func = Dep4Func extractClassDep :: Function -> Dep4Func extractClassDep (Constructor args _) = Dep4Func [] (concatMap classFromArg args) -extractClassDep (Virtual ret _ args _) = +extractClassDep (Virtual _ ret _ args _) = Dep4Func (extractClassFromType ret) (concatMap classFromArg args) -extractClassDep (NonVirtual ret _ args _) = +extractClassDep (NonVirtual _ ret _ args _) = Dep4Func (extractClassFromType ret) (concatMap classFromArg args) -extractClassDep (Static ret _ args _) = +extractClassDep (Static _ ret _ args _) = Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDep (Destructor _) = Dep4Func [] [] extractClassDepForTmplFun :: TemplateFunction -> Dep4Func -extractClassDepForTmplFun (TFun ret _ _ args) = +extractClassDepForTmplFun (TFun _ ret _ _ args) = Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDepForTmplFun (TFunNew args _) = Dep4Func [] (concatMap classFromArg args) extractClassDepForTmplFun TFunDelete = Dep4Func [] [] -extractClassDepForTmplFun (TFunOp ret _ e) = +extractClassDepForTmplFun (TFunOp _ ret _ e) = Dep4Func (extractClassFromType ret) (concatMap classFromArg $ argsFromOpExp e) extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func diff --git a/fficxx/src/FFICXX/Generate/Name.hs b/fficxx/src/FFICXX/Generate/Name.hs index c7eb6aee..60ddd536 100644 --- a/fficxx/src/FFICXX/Generate/Name.hs +++ b/fficxx/src/FFICXX/Generate/Name.hs @@ -98,9 +98,9 @@ aliasedFuncName :: Class -> Function -> String aliasedFuncName c f = case f of Constructor _ a -> fromMaybe (constructorName c) a - Virtual _ str _ a -> fromMaybe str a - NonVirtual _ str _ a -> fromMaybe (nonvirtualName c str) a - Static _ str _ a -> fromMaybe (nonvirtualName c str) a + Virtual _ _ str _ a -> fromMaybe str a + NonVirtual _ _ str _ a -> fromMaybe (nonvirtualName c str) a + Static _ _ str _ a -> fromMaybe (nonvirtualName c str) a Destructor a -> fromMaybe destructorName a hsTmplFuncName :: TemplateClass -> TemplateFunction -> String @@ -156,11 +156,11 @@ cppStaticName c f = class_name c <> "::" <> func_name f cppFuncName :: Class -> Function -> String cppFuncName c f = case f of - Constructor _ _ -> "new" - Virtual _ _ _ _ -> func_name f - NonVirtual _ _ _ _ -> func_name f - Static _ _ _ _ -> cppStaticName c f - Destructor _ -> destructorName + Constructor {} -> "new" + Virtual {} -> func_name f + NonVirtual {} -> func_name f + Static {} -> cppStaticName c f + Destructor {} -> destructorName constructorName :: Class -> String constructorName c = "new" <> (fst . hsClassName) c diff --git a/fficxx/src/FFICXX/Generate/Type/Class.hs b/fficxx/src/FFICXX/Generate/Type/Class.hs index aa1f7fcd..07046e3e 100644 --- a/fficxx/src/FFICXX/Generate/Type/Class.hs +++ b/fficxx/src/FFICXX/Generate/Type/Class.hs @@ -9,6 +9,7 @@ import Data.List (intercalate) import qualified Data.Map as M import Data.Maybe (mapMaybe) import FFICXX.Generate.Type.Cabal (Cabal) +import FFICXX.Runtime.Types (FFISafety (..)) -- | C types data CTypes @@ -128,19 +129,22 @@ data Function func_alias :: Maybe String } | Virtual - { func_ret :: Types, + { func_safety :: FFISafety, + func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String } | NonVirtual - { func_ret :: Types, + { func_safety :: FFISafety, + func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String } | Static - { func_ret :: Types, + { func_safety :: FFISafety, + func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String @@ -156,7 +160,8 @@ newtype Variable = Variable {unVariable :: Arg} -- | Member functions of a template class. data TemplateMemberFunction = TemplateMemberFunction - { tmf_params :: [String], + { tmf_safety :: FFISafety, + tmf_params :: [String], tmf_ret :: Types, tmf_name :: String, tmf_args :: [Arg], @@ -179,7 +184,8 @@ filterTLTemplate = mapMaybe (\case TLTemplate f -> Just f; _ -> Nothing) data TLOrdinary = TopLevelFunction - { toplevelfunc_ret :: Types, + { toplevelfunc_safety :: FFISafety, + toplevelfunc_ret :: Types, toplevelfunc_name :: String, toplevelfunc_args :: [Arg], toplevelfunc_alias :: Maybe String @@ -192,7 +198,8 @@ data TLOrdinary deriving (Show) data TLTemplate = TopLevelTemplateFunction - { topleveltfunc_params :: [String], + { topleveltfunc_safety :: FFISafety, + topleveltfunc_params :: [String], topleveltfunc_ret :: Types, topleveltfunc_name :: String, topleveltfunc_oname :: String, @@ -200,25 +207,30 @@ data TLTemplate = TopLevelTemplateFunction } deriving (Show) +getFunSafety :: Function -> FFISafety +getFunSafety (Constructor {}) = FFIUnsafe +getFunSafety (Destructor {}) = FFIUnsafe +getFunSafety f = func_safety f + isNewFunc :: Function -> Bool -isNewFunc (Constructor _ _) = True +isNewFunc (Constructor {}) = True isNewFunc _ = False isDeleteFunc :: Function -> Bool -isDeleteFunc (Destructor _) = True +isDeleteFunc (Destructor {}) = True isDeleteFunc _ = False isVirtualFunc :: Function -> Bool -isVirtualFunc (Destructor _) = True -isVirtualFunc (Virtual _ _ _ _) = True +isVirtualFunc (Destructor {}) = True +isVirtualFunc (Virtual {}) = True isVirtualFunc _ = False isNonVirtualFunc :: Function -> Bool -isNonVirtualFunc (NonVirtual _ _ _ _) = True +isNonVirtualFunc (NonVirtual {}) = True isNonVirtualFunc _ = False isStaticFunc :: Function -> Bool -isStaticFunc (Static _ _ _ _) = True +isStaticFunc (Static {}) = True isStaticFunc _ = False virtualFuncs :: [Function] -> [Function] @@ -290,7 +302,8 @@ data OpExp data TemplateFunction = TFun - { tfun_ret :: Types, + { tfun_safety :: FFISafety, + tfun_ret :: Types, tfun_name :: String, tfun_oname :: String, tfun_args :: [Arg] @@ -301,12 +314,18 @@ data TemplateFunction } | TFunDelete | TFunOp - { tfun_ret :: Types, + { tfun_safety :: FFISafety, + tfun_ret :: Types, -- | haskell alias for the operator tfun_name :: String, tfun_opexp :: OpExp } +getTFunSafety :: TemplateFunction -> FFISafety +getTFunSafety TFunNew {} = FFIUnsafe +getTFunSafety TFunDelete {} = FFIUnsafe +getTFunSafety f = tfun_safety f + argsFromOpExp :: OpExp -> [Arg] argsFromOpExp OpStar = [] argsFromOpExp OpFPPlus = [] diff --git a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs index f972191b..9f9f9885 100644 --- a/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs +++ b/fficxx/src/FFICXX/Generate/Util/GHCExactPrint.hs @@ -140,7 +140,7 @@ import GHC.Parser.Annotation AnnSortKey (..), DeltaPos (..), EpAnn (..), - EpAnnComments (EpaComments, EpaCommentsBalanced), + EpAnnComments (EpaComments), EpaComment (..), EpaCommentTok (..), EpaLocation (..), @@ -155,7 +155,6 @@ import GHC.Parser.Annotation TrailingAnn (..), emptyComments, noAnn, - noSrcSpanA, spanAsAnchor, ) import GHC.Types.Basic @@ -171,7 +170,6 @@ import GHC.Types.ForeignCall ) import GHC.Types.Name.Occurrence ( OccName, - mkOccName, mkTyVarOcc, mkVarOcc, ) @@ -189,19 +187,16 @@ import GHC.Types.SrcLoc RealSrcSpan, SrcSpan (..), mkSrcLoc, - mkSrcSpan, srcLocSpan, ) import qualified Language.Haskell.GHC.ExactPrint as Exact import Language.Haskell.Syntax - ( Anno, - CImportSpec (CFunction), + ( CImportSpec (CFunction), ClsInstDecl (..), ConDecl (..), DataDefnCons (..), DerivClauseTys (..), DocDecl (..), - ExprLStmt, FamEqn (..), ForeignDecl (..), ForeignImport (CImport), @@ -547,11 +542,22 @@ mkImportSrc name = -- NOTE: Unfortunately, the location annotation of GHC API for foreign import is not fully relative, -- i.e. we cannot place correct spaces between "import", "ccall" and "safe", and the generated result -- is not a valid Haskell code. So as a workaround we need to put a place holder in comment. -mkForImpCcall :: String -> String -> HsType GhcPs -> ForeignDecl GhcPs -mkForImpCcall quote fname typ = +mkForImpCcall :: + Safety -> + String -> + String -> + HsType GhcPs -> + ForeignDecl GhcPs +mkForImpCcall safety quote fname typ = ForeignImport (mkRelEpAnn (-1) annos) lid lsigty forImp where quote' = show quote + for_imp_header = + "foreign import ccall " + <> case safety of + PlayRisky -> "unsafe" + PlaySafe -> "safe" + PlayInterruptible -> "interruptible" annos = [ AddEpAnn AnnForeign @@ -561,7 +567,9 @@ mkForImpCcall quote fname typ = (mkRelAnchor 0) ( EpaComment ( EpaBlockComment - ( "{- REPLACE_THIS_LINE |foreign import ccall interruptible \"" + ( "{- REPLACE_THIS_LINE |" + <> for_imp_header + <> " \"" <> quote <> "\"| -}" ) @@ -585,7 +593,7 @@ mkForImpCcall quote fname typ = CImport (L defSrcSpan {- anchor_op = MovedAnchor (SameLine 1) -} (SourceText quote')) (L defSrcSpan {- anchor_op = MovedAnchor (SameLine 1) -} StdCallConv) - (L defSrcSpan {- anchor_op = MovedAnchor (SameLine 1) -} PlayInterruptible) + (L defSrcSpan {- anchor_op = MovedAnchor (SameLine 1) -} safety) Nothing ( CFunction (StaticTarget (SourceText quote) (fromString quote) Nothing True) diff --git a/stdcxx-gen/Gen.hs b/stdcxx-gen/Gen.hs index c563c681..5c3549ef 100644 --- a/stdcxx-gen/Gen.hs +++ b/stdcxx-gen/Gen.hs @@ -51,6 +51,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module (TemplateClassImportHeader (..)) import FFICXX.Generate.Type.PackageInterface () import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.FilePath (()) @@ -97,9 +98,9 @@ string = mempty (Just (ClassAlias {caHaskellName = "CppString", caFFIName = "string"})) [ Constructor [cstring "p"] Nothing, - NonVirtual cstring_ "c_str" [] Nothing, - NonVirtual (cppclassref_ string) "append" [cppclassref string "str"] Nothing, - NonVirtual (cppclassref_ string) "erase" [] Nothing + NonVirtual FFIUnsafe cstring_ "c_str" [] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "append" [cppclassref string "str"] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "erase" [] Nothing ] [] [] @@ -155,6 +156,7 @@ t_map = ["tpk", "tpv"] [ TFunNew [] Nothing, TFun + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_map_iterator, @@ -166,6 +168,7 @@ t_map = "begin" [], TFun + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_map_iterator, @@ -177,6 +180,7 @@ t_map = "end" [], TFun + FFIUnsafe void_ -- until pair is allowed "insert" "insert" @@ -190,7 +194,7 @@ t_map = ) "val" ], - TFun int_ "size" "size" [], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -203,7 +207,8 @@ t_map_iterator = (FormNested "std::map" "iterator") ["tpk", "tpv"] [ TFunOp - { tfun_ret = + { tfun_safety = FFIUnsafe, + tfun_ret = TemplateApp TemplateAppInfo { tapp_tclass = t_pair, @@ -214,7 +219,8 @@ t_map_iterator = tfun_opexp = OpStar }, TFunOp - { tfun_ret -- TODO: this should be handled with self + { tfun_safety = FFIUnsafe, + tfun_ret -- TODO: this should be handled with self = TemplateApp TemplateAppInfo @@ -237,6 +243,7 @@ t_vector = ["tp1"] [ TFunNew [] Nothing, TFun + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_vector_iterator, @@ -248,6 +255,7 @@ t_vector = "begin" [], TFun + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_vector_iterator, @@ -258,10 +266,10 @@ t_vector = "end" "end" [], - TFun void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], - TFun void_ "pop_back" "pop_back" [], - TFun (TemplateParam "tp1") "at" "at" [int "n"], - TFun int_ "size" "size" [], + TFun FFIUnsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], + TFun FFIUnsafe void_ "pop_back" "pop_back" [], + TFun FFIUnsafe (TemplateParam "tp1") "at" "at" [int "n"], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -274,12 +282,14 @@ t_vector_iterator = (FormNested "std::vector" "iterator") ["tp1"] [ TFunOp - { tfun_ret = TemplateParam "tp1", + { tfun_safety = FFIUnsafe, + tfun_ret = TemplateParam "tp1", tfun_name = "deRef", tfun_opexp = OpStar }, TFunOp - { tfun_ret -- TODO: this should be handled with self + { tfun_safety = FFIUnsafe, + tfun_ret -- TODO: this should be handled with self = TemplateApp TemplateAppInfo @@ -302,9 +312,9 @@ t_unique_ptr = ["tp1"] [ TFunNew [] (Just "newUniquePtr0"), TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing, - TFun (TemplateParamPointer "tp1") "get" "get" [], - TFun (TemplateParamPointer "tp1") "release" "release" [], - TFun void_ "reset" "reset" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "get" "get" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "release" "release" [], + TFun FFIUnsafe void_ "reset" "reset" [], TFunDelete ] [] @@ -318,9 +328,9 @@ t_shared_ptr = ["tp1"] [ TFunNew [] (Just "newSharedPtr0"), TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing, - TFun (TemplateParamPointer "tp1") "get" "get" [], - TFun void_ "reset" "reset" [], - TFun int_ "use_count" "use_count" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "get" "get" [], + TFun FFIUnsafe void_ "reset" "reset" [], + TFun FFIUnsafe int_ "use_count" "use_count" [], TFunDelete ] [] From c5f75027ee3bdb4c88ec395a47c1bc02431bd073 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Sun, 27 Aug 2023 22:09:35 -0700 Subject: [PATCH 18/19] fix missing parentheses around types in haskell code generation (#230) The bugs were introduced when migrated from haskell-src-exts to ghc-exactprint. --- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 54 ++++++-------------- 1 file changed, 17 insertions(+), 37 deletions(-) diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index ce9855c6..e2268ea8 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -827,7 +827,7 @@ extractArgRetTypes mc isvirtual (CFunSig args ret) = then return (Ex.mkTVar "a") else return $ Ex.tycon ((fst . hsClassName) c) x -> (return . cxx2HsType Nothing) x - return (as ++ [Ex.tyapp (Ex.tycon "IO") r]) + return (as ++ [Ex.tyapp (Ex.tycon "IO") (Ex.tyParen r)]) in HsFunSig { hsSigTypes = typs, hsSigConstraints = fst s @@ -1008,28 +1008,18 @@ hsFFIFunType msc (CFunSig args ret) = rawname = snd (hsClassName d) hsargtype (TemplateApp x) = Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp $ - map Ex.tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsargtype (TemplateAppRef x) = - Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp $ - map Ex.tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsargtype (TemplateAppMove x) = - Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp $ - map Ex.tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) + Ex.tyParen $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsargtype (TemplateAppRef x) = hsargtype (TemplateApp x) + hsargtype (TemplateAppMove x) = hsargtype (TemplateApp x) hsargtype (TemplateType t) = Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp (Ex.tycon rawname : map Ex.mkTVar (tclass_params t)) + Ex.tyParen $ + foldl1 Ex.tyapp (Ex.tycon rawname : map Ex.mkTVar (tclass_params t)) where rawname = snd (hsTemplateClassName t) hsargtype (TemplateParam p) = Ex.mkTVar p @@ -1054,28 +1044,18 @@ hsFFIFunType msc (CFunSig args ret) = rawname = snd (hsClassName d) hsrettype (TemplateApp x) = Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp $ - map Ex.tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsrettype (TemplateAppRef x) = - Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp $ - map Ex.tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) - where - rawname = snd (hsTemplateClassName (tapp_tclass x)) - hsrettype (TemplateAppMove x) = - Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp $ - map Ex.tycon $ - rawname : map hsClassNameForTArg (tapp_tparams x) + Ex.tyParen $ + foldl1 Ex.tyapp $ + map Ex.tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsrettype (TemplateAppRef x) = hsrettype (TemplateApp x) + hsrettype (TemplateAppMove x) = hsrettype (TemplateApp x) hsrettype (TemplateType t) = Ex.tyapp Ex.tyPtr $ - foldl1 Ex.tyapp (Ex.tycon rawname : map Ex.mkTVar (tclass_params t)) + Ex.tyParen $ + foldl1 Ex.tyapp (Ex.tycon rawname : map Ex.mkTVar (tclass_params t)) where rawname = snd (hsTemplateClassName t) hsrettype (TemplateParam p) = Ex.mkTVar p From a0808b2daa1d1ed6d1c1c5cef265bdff9b937910 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Wed, 30 Aug 2023 11:54:50 -0700 Subject: [PATCH 19/19] parenthesis around #{const ..}. (#231) --- fficxx/src/FFICXX/Generate/Code/HsEnum.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fficxx/src/FFICXX/Generate/Code/HsEnum.hs b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs index 3eaa690b..13fb1813 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsEnum.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs @@ -57,7 +57,7 @@ genHsEnumDecl enum = mk1to1 (x, y) = ([mkPVar x], mkVar y, EmptyLocalBinds noExtField) mkFromIntegralCxx x = mkVar "fromIntegral" - `app` mkVarWithComment "" ("#{const " <> x <> "}") + `app` mkVarWithComment "" ("( #{const " <> x <> "} )") -- NOTE: toEnum should not be used. -- TODO: make this somewhat safer with error messages. mkToEnum = [([wildcard], mkVar "undefined", EmptyLocalBinds noExtField)]