From 5d1d6869ebcb72baeb474b8d15d2098a397adfed Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 6 Dec 2024 01:03:02 +0200 Subject: [PATCH] Generate pattern synonym for enum values --- hs-bindgen/fixtures/distilled_lib_1.hs | 6 ++++ hs-bindgen/fixtures/distilled_lib_1.pp.hs | 12 +++++++ hs-bindgen/fixtures/distilled_lib_1.th.txt | 12 +++++++ hs-bindgen/fixtures/enums.hs | 18 ++++++++++ hs-bindgen/fixtures/enums.pp.hs | 36 +++++++++++++++++++ hs-bindgen/fixtures/enums.th.txt | 36 +++++++++++++++++++ hs-bindgen/fixtures/typenames.hs | 2 ++ hs-bindgen/fixtures/typenames.pp.hs | 4 +++ hs-bindgen/fixtures/typenames.th.txt | 4 +++ hs-bindgen/fixtures/uses_utf8.hs | 2 ++ hs-bindgen/fixtures/uses_utf8.pp.hs | 4 +++ hs-bindgen/fixtures/uses_utf8.th.txt | 4 +++ hs-bindgen/src/HsBindgen/Backend/PP/Render.hs | 9 +++-- .../src/HsBindgen/Backend/PP/Translation.hs | 3 ++ hs-bindgen/src/HsBindgen/Backend/TH.hs | 30 ++++++++++++++++ hs-bindgen/src/HsBindgen/Hs/AST.hs | 24 +++++++++++++ hs-bindgen/src/HsBindgen/Hs/Translation.hs | 36 ++++++++++++------- hs-bindgen/src/HsBindgen/Imports.hs | 1 + hs-bindgen/src/HsBindgen/SHs/AST.hs | 15 ++++++-- hs-bindgen/src/HsBindgen/SHs/Translation.hs | 10 +++++- 20 files changed, 249 insertions(+), 19 deletions(-) diff --git a/hs-bindgen/fixtures/distilled_lib_1.hs b/hs-bindgen/fixtures/distilled_lib_1.hs index a18ff0c8..765fcbf5 100644 --- a/hs-bindgen/fixtures/distilled_lib_1.hs +++ b/hs-bindgen/fixtures/distilled_lib_1.hs @@ -9,6 +9,8 @@ DeclData (Struct {structName = "CAnotherTypedefStructT", structConstr = "MkCAnot DeclInstance (InstanceStorable (Struct {structName = "CAnotherTypedefStructT", structConstr = "MkCAnotherTypedefStructT", structFields = ("cAnotherTypedefStructT_foo",HsPrimType HsPrimCInt) ::: ("cAnotherTypedefStructT_bar",HsPrimType HsPrimCChar) ::: VNil}) (StorableInstance {storableSizeOf = 8, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CAnotherTypedefStructT", structConstr = "MkCAnotherTypedefStructT", structFields = ("cAnotherTypedefStructT_foo",HsPrimType HsPrimCInt) ::: ("cAnotherTypedefStructT_bar",HsPrimType HsPrimCChar) ::: VNil})) [PeekByteOff 0 0,PeekByteOff 0 4]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CAnotherTypedefStructT", structConstr = "MkCAnotherTypedefStructT", structFields = ("cAnotherTypedefStructT_foo",HsPrimType HsPrimCInt) ::: ("cAnotherTypedefStructT_bar",HsPrimType HsPrimCChar) ::: VNil}) 2 (Seq [PokeByteOff 3 0 0,PokeByteOff 3 4 1])))})) DeclNewtype (Newtype {newtypeName = "CAnotherTypedefEnumE", newtypeConstr = "MkCAnotherTypedefEnumE", newtypeField = "unCAnotherTypedefEnumE", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CAnotherTypedefEnumE", structConstr = "MkCAnotherTypedefEnumE", structFields = ("unCAnotherTypedefEnumE",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CAnotherTypedefEnumE", structConstr = "MkCAnotherTypedefEnumE", structFields = ("unCAnotherTypedefEnumE",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CAnotherTypedefEnumE", structConstr = "MkCAnotherTypedefEnumE", structFields = ("unCAnotherTypedefEnumE",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCFOO", patSynType = "CAnotherTypedefEnumE", patSynConstr = "MkCAnotherTypedefEnumE", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCBAR", patSynType = "CAnotherTypedefEnumE", patSynConstr = "MkCAnotherTypedefEnumE", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CATypeT", newtypeConstr = "MkCATypeT", newtypeField = "unCATypeT", newtypeType = HsPrimType HsPrimCInt}) DeclNewtypeInstance Storable "CATypeT" DeclNewtype (Newtype {newtypeName = "CVarT", newtypeConstr = "MkCVarT", newtypeField = "unCVarT", newtypeType = HsPrimType HsPrimCInt}) @@ -25,6 +27,10 @@ DeclNewtype (Newtype {newtypeName = "CATypedefStructT", newtypeConstr = "MkCATyp DeclNewtypeInstance Storable "CATypedefStructT" DeclNewtype (Newtype {newtypeName = "CATypedefEnumE", newtypeConstr = "MkCATypedefEnumE", newtypeField = "unCATypedefEnumE", newtypeType = HsPrimType HsPrimCSChar}) DeclInstance (InstanceStorable (Struct {structName = "CATypedefEnumE", structConstr = "MkCATypedefEnumE", structFields = ("unCATypedefEnumE",HsPrimType HsPrimCSChar) ::: VNil}) (StorableInstance {storableSizeOf = 1, storableAlignment = 1, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CATypedefEnumE", structConstr = "MkCATypedefEnumE", structFields = ("unCATypedefEnumE",HsPrimType HsPrimCSChar) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CATypedefEnumE", structConstr = "MkCATypedefEnumE", structFields = ("unCATypedefEnumE",HsPrimType HsPrimCSChar) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCENUMCASE0", patSynType = "CATypedefEnumE", patSynConstr = "MkCATypedefEnumE", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCENUMCASE1", patSynType = "CATypedefEnumE", patSynConstr = "MkCATypedefEnumE", patSynValue = 1}) +DeclPatSyn (PatSyn {patSynName = "MkCENUMCASE2", patSynType = "CATypedefEnumE", patSynConstr = "MkCATypedefEnumE", patSynValue = 2}) +DeclPatSyn (PatSyn {patSynName = "MkCENUMCASE3", patSynType = "CATypedefEnumE", patSynConstr = "MkCATypedefEnumE", patSynValue = 3}) DeclNewtype (Newtype {newtypeName = "CInt32T", newtypeConstr = "MkCInt32T", newtypeField = "unCInt32T", newtypeType = HsPrimType HsPrimCInt}) DeclNewtypeInstance Storable "CInt32T" DeclNewtype (Newtype {newtypeName = "CCallbackT", newtypeConstr = "MkCCallbackT", newtypeField = "unCCallbackT", newtypeType = HsFunPtr (HsFun (HsPtr (HsPrimType HsPrimVoid)) (HsFun (HsTypRef "CUint32T") (HsIO (HsTypRef "CUint32T"))))}) diff --git a/hs-bindgen/fixtures/distilled_lib_1.pp.hs b/hs-bindgen/fixtures/distilled_lib_1.pp.hs index bd1aaa98..66b6705a 100644 --- a/hs-bindgen/fixtures/distilled_lib_1.pp.hs +++ b/hs-bindgen/fixtures/distilled_lib_1.pp.hs @@ -77,6 +77,10 @@ instance F.Storable CAnotherTypedefEnumE where MkCAnotherTypedefEnumE unCAnotherTypedefEnumE2 -> F.pokeByteOff ptr0 0 unCAnotherTypedefEnumE2 +-- TODO pattern + +-- TODO pattern + newtype CATypeT = MkCATypeT { unCATypeT :: FC.CInt } @@ -197,6 +201,14 @@ instance F.Storable CATypedefEnumE where case s1 of MkCATypedefEnumE unCATypedefEnumE2 -> F.pokeByteOff ptr0 0 unCATypedefEnumE2 +-- TODO pattern + +-- TODO pattern + +-- TODO pattern + +-- TODO pattern + newtype CInt32T = MkCInt32T { unCInt32T :: FC.CInt } diff --git a/hs-bindgen/fixtures/distilled_lib_1.th.txt b/hs-bindgen/fixtures/distilled_lib_1.th.txt index 749dd553..b61bcb31 100644 --- a/hs-bindgen/fixtures/distilled_lib_1.th.txt +++ b/hs-bindgen/fixtures/distilled_lib_1.th.txt @@ -30,6 +30,10 @@ instance Storable CAnotherTypedefEnumE peek = \ptr_0 -> pure MkCAnotherTypedefEnumE <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCAnotherTypedefEnumE unCAnotherTypedefEnumE_3 -> pokeByteOff ptr_1 0 unCAnotherTypedefEnumE_3}} +pattern MkCFOO :: CAnotherTypedefEnumE +pattern MkCFOO = MkCAnotherTypedefEnumE 0 +pattern MkCBAR :: CAnotherTypedefEnumE +pattern MkCBAR = MkCAnotherTypedefEnumE 1 newtype CATypeT = MkCATypeT {unCATypeT :: CInt} deriving newtype instance Storable CATypeT newtype CVarT = MkCVarT {unCVarT :: CInt} @@ -79,6 +83,14 @@ instance Storable CATypedefEnumE peek = \ptr_0 -> pure MkCATypedefEnumE <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCATypedefEnumE unCATypedefEnumE_3 -> pokeByteOff ptr_1 0 unCATypedefEnumE_3}} +pattern MkCENUMCASE0 :: CATypedefEnumE +pattern MkCENUMCASE0 = MkCATypedefEnumE 0 +pattern MkCENUMCASE1 :: CATypedefEnumE +pattern MkCENUMCASE1 = MkCATypedefEnumE 1 +pattern MkCENUMCASE2 :: CATypedefEnumE +pattern MkCENUMCASE2 = MkCATypedefEnumE 2 +pattern MkCENUMCASE3 :: CATypedefEnumE +pattern MkCENUMCASE3 = MkCATypedefEnumE 3 newtype CInt32T = MkCInt32T {unCInt32T :: CInt} deriving newtype instance Storable CInt32T newtype CCallbackT diff --git a/hs-bindgen/fixtures/enums.hs b/hs-bindgen/fixtures/enums.hs index 95efe089..b116ba9a 100644 --- a/hs-bindgen/fixtures/enums.hs +++ b/hs-bindgen/fixtures/enums.hs @@ -1,18 +1,36 @@ DeclNewtype (Newtype {newtypeName = "CFirst", newtypeConstr = "MkCFirst", newtypeField = "unCFirst", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CFirst", structConstr = "MkCFirst", structFields = ("unCFirst",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CFirst", structConstr = "MkCFirst", structFields = ("unCFirst",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CFirst", structConstr = "MkCFirst", structFields = ("unCFirst",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCFIRST1", patSynType = "CFirst", patSynConstr = "MkCFirst", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCFIRST2", patSynType = "CFirst", patSynConstr = "MkCFirst", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CSecond", newtypeConstr = "MkCSecond", newtypeField = "unCSecond", newtypeType = HsPrimType HsPrimCInt}) DeclInstance (InstanceStorable (Struct {structName = "CSecond", structConstr = "MkCSecond", structFields = ("unCSecond",HsPrimType HsPrimCInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CSecond", structConstr = "MkCSecond", structFields = ("unCSecond",HsPrimType HsPrimCInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CSecond", structConstr = "MkCSecond", structFields = ("unCSecond",HsPrimType HsPrimCInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCSECONDA", patSynType = "CSecond", patSynConstr = "MkCSecond", patSynValue = -1}) +DeclPatSyn (PatSyn {patSynName = "MkCSECONDB", patSynType = "CSecond", patSynConstr = "MkCSecond", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCSECONDC", patSynType = "CSecond", patSynConstr = "MkCSecond", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CSame", newtypeConstr = "MkCSame", newtypeField = "unCSame", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CSame", structConstr = "MkCSame", structFields = ("unCSame",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CSame", structConstr = "MkCSame", structFields = ("unCSame",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CSame", structConstr = "MkCSame", structFields = ("unCSame",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCSAMEA", patSynType = "CSame", patSynConstr = "MkCSame", patSynValue = 1}) +DeclPatSyn (PatSyn {patSynName = "MkCSAMEB", patSynType = "CSame", patSynConstr = "MkCSame", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CPackad", newtypeConstr = "MkCPackad", newtypeField = "unCPackad", newtypeType = HsPrimType HsPrimCSChar}) DeclInstance (InstanceStorable (Struct {structName = "CPackad", structConstr = "MkCPackad", structFields = ("unCPackad",HsPrimType HsPrimCSChar) ::: VNil}) (StorableInstance {storableSizeOf = 1, storableAlignment = 1, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CPackad", structConstr = "MkCPackad", structFields = ("unCPackad",HsPrimType HsPrimCSChar) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CPackad", structConstr = "MkCPackad", structFields = ("unCPackad",HsPrimType HsPrimCSChar) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCPACKEDA", patSynType = "CPackad", patSynConstr = "MkCPackad", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCPACKEDB", patSynType = "CPackad", patSynConstr = "MkCPackad", patSynValue = 1}) +DeclPatSyn (PatSyn {patSynName = "MkCPACKEDC", patSynType = "CPackad", patSynConstr = "MkCPackad", patSynValue = 2}) DeclNewtype (Newtype {newtypeName = "CEnumA", newtypeConstr = "MkCEnumA", newtypeField = "unCEnumA", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CEnumA", structConstr = "MkCEnumA", structFields = ("unCEnumA",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CEnumA", structConstr = "MkCEnumA", structFields = ("unCEnumA",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CEnumA", structConstr = "MkCEnumA", structFields = ("unCEnumA",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCAFOO", patSynType = "CEnumA", patSynConstr = "MkCEnumA", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCABAR", patSynType = "CEnumA", patSynConstr = "MkCEnumA", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CEnumB", newtypeConstr = "MkCEnumB", newtypeField = "unCEnumB", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CEnumB", structConstr = "MkCEnumB", structFields = ("unCEnumB",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CEnumB", structConstr = "MkCEnumB", structFields = ("unCEnumB",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CEnumB", structConstr = "MkCEnumB", structFields = ("unCEnumB",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCBFOO", patSynType = "CEnumB", patSynConstr = "MkCEnumB", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCBBAR", patSynType = "CEnumB", patSynConstr = "MkCEnumB", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CEnumC", newtypeConstr = "MkCEnumC", newtypeField = "unCEnumC", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CEnumC", structConstr = "MkCEnumC", structFields = ("unCEnumC",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CEnumC", structConstr = "MkCEnumC", structFields = ("unCEnumC",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CEnumC", structConstr = "MkCEnumC", structFields = ("unCEnumC",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCCFOO", patSynType = "CEnumC", patSynConstr = "MkCEnumC", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCCBAR", patSynType = "CEnumC", patSynConstr = "MkCEnumC", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CEnumD", newtypeConstr = "MkCEnumD", newtypeField = "unCEnumD", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CEnumD", structConstr = "MkCEnumD", structFields = ("unCEnumD",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CEnumD", structConstr = "MkCEnumD", structFields = ("unCEnumD",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CEnumD", structConstr = "MkCEnumD", structFields = ("unCEnumD",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCDFOO", patSynType = "CEnumD", patSynConstr = "MkCEnumD", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCDBAR", patSynType = "CEnumD", patSynConstr = "MkCEnumD", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CEnumDT", newtypeConstr = "MkCEnumDT", newtypeField = "unCEnumDT", newtypeType = HsTypRef "CEnumD"}) DeclNewtypeInstance Storable "CEnumDT" diff --git a/hs-bindgen/fixtures/enums.pp.hs b/hs-bindgen/fixtures/enums.pp.hs index aba6ed34..c31267ef 100644 --- a/hs-bindgen/fixtures/enums.pp.hs +++ b/hs-bindgen/fixtures/enums.pp.hs @@ -27,6 +27,10 @@ instance F.Storable CFirst where case s1 of MkCFirst unCFirst2 -> F.pokeByteOff ptr0 0 unCFirst2 +-- TODO pattern + +-- TODO pattern + newtype CSecond = MkCSecond { unCSecond :: FC.CInt } @@ -48,6 +52,12 @@ instance F.Storable CSecond where case s1 of MkCSecond unCSecond2 -> F.pokeByteOff ptr0 0 unCSecond2 +-- TODO pattern + +-- TODO pattern + +-- TODO pattern + newtype CSame = MkCSame { unCSame :: FC.CUInt } @@ -69,6 +79,10 @@ instance F.Storable CSame where case s1 of MkCSame unCSame2 -> F.pokeByteOff ptr0 0 unCSame2 +-- TODO pattern + +-- TODO pattern + newtype CPackad = MkCPackad { unCPackad :: FC.CSChar } @@ -90,6 +104,12 @@ instance F.Storable CPackad where case s1 of MkCPackad unCPackad2 -> F.pokeByteOff ptr0 0 unCPackad2 +-- TODO pattern + +-- TODO pattern + +-- TODO pattern + newtype CEnumA = MkCEnumA { unCEnumA :: FC.CUInt } @@ -111,6 +131,10 @@ instance F.Storable CEnumA where case s1 of MkCEnumA unCEnumA2 -> F.pokeByteOff ptr0 0 unCEnumA2 +-- TODO pattern + +-- TODO pattern + newtype CEnumB = MkCEnumB { unCEnumB :: FC.CUInt } @@ -132,6 +156,10 @@ instance F.Storable CEnumB where case s1 of MkCEnumB unCEnumB2 -> F.pokeByteOff ptr0 0 unCEnumB2 +-- TODO pattern + +-- TODO pattern + newtype CEnumC = MkCEnumC { unCEnumC :: FC.CUInt } @@ -153,6 +181,10 @@ instance F.Storable CEnumC where case s1 of MkCEnumC unCEnumC2 -> F.pokeByteOff ptr0 0 unCEnumC2 +-- TODO pattern + +-- TODO pattern + newtype CEnumD = MkCEnumD { unCEnumD :: FC.CUInt } @@ -174,6 +206,10 @@ instance F.Storable CEnumD where case s1 of MkCEnumD unCEnumD2 -> F.pokeByteOff ptr0 0 unCEnumD2 +-- TODO pattern + +-- TODO pattern + newtype CEnumDT = MkCEnumDT { unCEnumDT :: CEnumD } diff --git a/hs-bindgen/fixtures/enums.th.txt b/hs-bindgen/fixtures/enums.th.txt index d08d51ea..3dec28d7 100644 --- a/hs-bindgen/fixtures/enums.th.txt +++ b/hs-bindgen/fixtures/enums.th.txt @@ -5,6 +5,10 @@ instance Storable CFirst peek = \ptr_0 -> pure MkCFirst <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCFirst unCFirst_3 -> pokeByteOff ptr_1 0 unCFirst_3}} +pattern MkCFIRST1 :: CFirst +pattern MkCFIRST1 = MkCFirst 0 +pattern MkCFIRST2 :: CFirst +pattern MkCFIRST2 = MkCFirst 1 newtype CSecond = MkCSecond {unCSecond :: CInt} instance Storable CSecond where {sizeOf = \_ -> 4; @@ -12,6 +16,12 @@ instance Storable CSecond peek = \ptr_0 -> pure MkCSecond <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCSecond unCSecond_3 -> pokeByteOff ptr_1 0 unCSecond_3}} +pattern MkCSECONDA :: CSecond +pattern MkCSECONDA = MkCSecond (-1) +pattern MkCSECONDB :: CSecond +pattern MkCSECONDB = MkCSecond 0 +pattern MkCSECONDC :: CSecond +pattern MkCSECONDC = MkCSecond 1 newtype CSame = MkCSame {unCSame :: CUInt} instance Storable CSame where {sizeOf = \_ -> 4; @@ -19,6 +29,10 @@ instance Storable CSame peek = \ptr_0 -> pure MkCSame <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCSame unCSame_3 -> pokeByteOff ptr_1 0 unCSame_3}} +pattern MkCSAMEA :: CSame +pattern MkCSAMEA = MkCSame 1 +pattern MkCSAMEB :: CSame +pattern MkCSAMEB = MkCSame 1 newtype CPackad = MkCPackad {unCPackad :: CSChar} instance Storable CPackad where {sizeOf = \_ -> 1; @@ -26,6 +40,12 @@ instance Storable CPackad peek = \ptr_0 -> pure MkCPackad <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCPackad unCPackad_3 -> pokeByteOff ptr_1 0 unCPackad_3}} +pattern MkCPACKEDA :: CPackad +pattern MkCPACKEDA = MkCPackad 0 +pattern MkCPACKEDB :: CPackad +pattern MkCPACKEDB = MkCPackad 1 +pattern MkCPACKEDC :: CPackad +pattern MkCPACKEDC = MkCPackad 2 newtype CEnumA = MkCEnumA {unCEnumA :: CUInt} instance Storable CEnumA where {sizeOf = \_ -> 4; @@ -33,6 +53,10 @@ instance Storable CEnumA peek = \ptr_0 -> pure MkCEnumA <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCEnumA unCEnumA_3 -> pokeByteOff ptr_1 0 unCEnumA_3}} +pattern MkCAFOO :: CEnumA +pattern MkCAFOO = MkCEnumA 0 +pattern MkCABAR :: CEnumA +pattern MkCABAR = MkCEnumA 1 newtype CEnumB = MkCEnumB {unCEnumB :: CUInt} instance Storable CEnumB where {sizeOf = \_ -> 4; @@ -40,6 +64,10 @@ instance Storable CEnumB peek = \ptr_0 -> pure MkCEnumB <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCEnumB unCEnumB_3 -> pokeByteOff ptr_1 0 unCEnumB_3}} +pattern MkCBFOO :: CEnumB +pattern MkCBFOO = MkCEnumB 0 +pattern MkCBBAR :: CEnumB +pattern MkCBBAR = MkCEnumB 1 newtype CEnumC = MkCEnumC {unCEnumC :: CUInt} instance Storable CEnumC where {sizeOf = \_ -> 4; @@ -47,6 +75,10 @@ instance Storable CEnumC peek = \ptr_0 -> pure MkCEnumC <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCEnumC unCEnumC_3 -> pokeByteOff ptr_1 0 unCEnumC_3}} +pattern MkCCFOO :: CEnumC +pattern MkCCFOO = MkCEnumC 0 +pattern MkCCBAR :: CEnumC +pattern MkCCBAR = MkCEnumC 1 newtype CEnumD = MkCEnumD {unCEnumD :: CUInt} instance Storable CEnumD where {sizeOf = \_ -> 4; @@ -54,5 +86,9 @@ instance Storable CEnumD peek = \ptr_0 -> pure MkCEnumD <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCEnumD unCEnumD_3 -> pokeByteOff ptr_1 0 unCEnumD_3}} +pattern MkCDFOO :: CEnumD +pattern MkCDFOO = MkCEnumD 0 +pattern MkCDBAR :: CEnumD +pattern MkCDBAR = MkCEnumD 1 newtype CEnumDT = MkCEnumDT {unCEnumDT :: CEnumD} deriving newtype instance Storable CEnumDT diff --git a/hs-bindgen/fixtures/typenames.hs b/hs-bindgen/fixtures/typenames.hs index 844aeeeb..40351355 100644 --- a/hs-bindgen/fixtures/typenames.hs +++ b/hs-bindgen/fixtures/typenames.hs @@ -1,4 +1,6 @@ DeclNewtype (Newtype {newtypeName = "CFoo", newtypeConstr = "MkCFoo", newtypeField = "unCFoo", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("unCFoo",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("unCFoo",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CFoo", structConstr = "MkCFoo", structFields = ("unCFoo",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCFOO1", patSynType = "CFoo", patSynConstr = "MkCFoo", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCFOO2", patSynType = "CFoo", patSynConstr = "MkCFoo", patSynValue = 1}) DeclNewtype (Newtype {newtypeName = "CFoo", newtypeConstr = "MkCFoo", newtypeField = "unCFoo", newtypeType = HsPrimType HsPrimCDouble}) DeclNewtypeInstance Storable "CFoo" diff --git a/hs-bindgen/fixtures/typenames.pp.hs b/hs-bindgen/fixtures/typenames.pp.hs index 3f5ba8d6..8da1e804 100644 --- a/hs-bindgen/fixtures/typenames.pp.hs +++ b/hs-bindgen/fixtures/typenames.pp.hs @@ -27,6 +27,10 @@ instance F.Storable CFoo where case s1 of MkCFoo unCFoo2 -> F.pokeByteOff ptr0 0 unCFoo2 +-- TODO pattern + +-- TODO pattern + newtype CFoo = MkCFoo { unCFoo :: FC.CDouble } diff --git a/hs-bindgen/fixtures/typenames.th.txt b/hs-bindgen/fixtures/typenames.th.txt index 4d2f3370..9384b451 100644 --- a/hs-bindgen/fixtures/typenames.th.txt +++ b/hs-bindgen/fixtures/typenames.th.txt @@ -5,5 +5,9 @@ instance Storable CFoo peek = \ptr_0 -> pure MkCFoo <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCFoo unCFoo_3 -> pokeByteOff ptr_1 0 unCFoo_3}} +pattern MkCFOO1 :: CFoo +pattern MkCFOO1 = MkCFoo 0 +pattern MkCFOO2 :: CFoo +pattern MkCFOO2 = MkCFoo 1 newtype CFoo = MkCFoo {unCFoo :: CDouble} deriving newtype instance Storable CFoo diff --git a/hs-bindgen/fixtures/uses_utf8.hs b/hs-bindgen/fixtures/uses_utf8.hs index 90790a93..59c3106d 100644 --- a/hs-bindgen/fixtures/uses_utf8.hs +++ b/hs-bindgen/fixtures/uses_utf8.hs @@ -1,2 +1,4 @@ DeclNewtype (Newtype {newtypeName = "CMyEnum", newtypeConstr = "MkCMyEnum", newtypeField = "unCMyEnum", newtypeType = HsPrimType HsPrimCUInt}) DeclInstance (InstanceStorable (Struct {structName = "CMyEnum", structConstr = "MkCMyEnum", structFields = ("unCMyEnum",HsPrimType HsPrimCUInt) ::: VNil}) (StorableInstance {storableSizeOf = 4, storableAlignment = 4, storablePeek = Lambda "ptr" (Ap (StructCon (Struct {structName = "CMyEnum", structConstr = "MkCMyEnum", structFields = ("unCMyEnum",HsPrimType HsPrimCUInt) ::: VNil})) [PeekByteOff 0 0]), storablePoke = Lambda "ptr" (Lambda "s" (ElimStruct 0 (Struct {structName = "CMyEnum", structConstr = "MkCMyEnum", structFields = ("unCMyEnum",HsPrimType HsPrimCUInt) ::: VNil}) 1 (Seq [PokeByteOff 2 0 0])))})) +DeclPatSyn (PatSyn {patSynName = "MkCSay\20320\22909", patSynType = "CMyEnum", patSynConstr = "MkCMyEnum", patSynValue = 0}) +DeclPatSyn (PatSyn {patSynName = "MkCSay\25308\25308", patSynType = "CMyEnum", patSynConstr = "MkCMyEnum", patSynValue = 1}) diff --git a/hs-bindgen/fixtures/uses_utf8.pp.hs b/hs-bindgen/fixtures/uses_utf8.pp.hs index 57c952a1..6ab3c6ce 100644 --- a/hs-bindgen/fixtures/uses_utf8.pp.hs +++ b/hs-bindgen/fixtures/uses_utf8.pp.hs @@ -26,3 +26,7 @@ instance F.Storable CMyEnum where \s1 -> case s1 of MkCMyEnum unCMyEnum2 -> F.pokeByteOff ptr0 0 unCMyEnum2 + +-- TODO pattern + +-- TODO pattern diff --git a/hs-bindgen/fixtures/uses_utf8.th.txt b/hs-bindgen/fixtures/uses_utf8.th.txt index e6ce9de8..ac0a07bf 100644 --- a/hs-bindgen/fixtures/uses_utf8.th.txt +++ b/hs-bindgen/fixtures/uses_utf8.th.txt @@ -5,3 +5,7 @@ instance Storable CMyEnum peek = \ptr_0 -> pure MkCMyEnum <*> peekByteOff ptr_0 0; poke = \ptr_1 -> \s_2 -> case s_2 of {MkCMyEnum unCMyEnum_3 -> pokeByteOff ptr_1 0 unCMyEnum_3}} +pattern MkCSay你好 :: CMyEnum +pattern MkCSay你好 = MkCMyEnum 0 +pattern MkCSay拜拜 :: CMyEnum +pattern MkCSay拜拜 = MkCMyEnum 1 diff --git a/hs-bindgen/src/HsBindgen/Backend/PP/Render.hs b/hs-bindgen/src/HsBindgen/Backend/PP/Render.hs index 176f387a..c2ffdb8a 100644 --- a/hs-bindgen/src/HsBindgen/Backend/PP/Render.hs +++ b/hs-bindgen/src/HsBindgen/Backend/PP/Render.hs @@ -125,6 +125,9 @@ instance Pretty SDecl where DDerivingNewtypeInstance t -> "deriving newtype instance" <+> pretty t + DPatternSynonym _ -> + "-- TODO pattern" + {------------------------------------------------------------------------------- Type pretty-printing -------------------------------------------------------------------------------} @@ -164,7 +167,7 @@ prettyExpr env prec = \case EFree x -> pretty x ECon n -> pretty n - EIntegral i _ -> showToCtxDoc i + EIntegral i _ -> showToCtxDoc i -- TODO: why we have type annotation if we don't use it? EFloat f | canBeRepresentedAsRational f -> showToCtxDoc f @@ -173,7 +176,7 @@ prettyExpr env prec = \case prettyExpr env prec $ EApp (EGlobal CFloat_constructor) $ EApp (EGlobal GHC_Float_castWord32ToFloat) $ - EIntegral (toInteger $ castFloatToWord32 f) HsPrimCUInt + EIntegral (toInteger $ castFloatToWord32 f) (Just HsPrimCUInt) EDouble f | canBeRepresentedAsRational f -> showToCtxDoc f @@ -182,7 +185,7 @@ prettyExpr env prec = \case prettyExpr env prec $ EApp (EGlobal CDouble_constructor) $ EApp (EGlobal GHC_Float_castWord64ToDouble) $ - EIntegral (toInteger $ castDoubleToWord64 f) HsPrimCULong + EIntegral (toInteger $ castDoubleToWord64 f) (Just HsPrimCULong) EApp f x -> parensWhen (prec > 3) $ prettyExpr env 3 f <+> prettyExpr env 4 x diff --git a/hs-bindgen/src/HsBindgen/Backend/PP/Translation.hs b/hs-bindgen/src/HsBindgen/Backend/PP/Translation.hs index c67e8f28..b4d78d46 100644 --- a/hs-bindgen/src/HsBindgen/Backend/PP/Translation.hs +++ b/hs-bindgen/src/HsBindgen/Backend/PP/Translation.hs @@ -117,6 +117,9 @@ resolveDeclImports = \case DEmptyData _name -> mempty DNewtype Newtype{..} -> resolveTypeImports newtypeType DDerivingNewtypeInstance ty -> resolveTypeImports ty + DPatternSynonym PatternSynonym {..} -> + resolveTypeImports patSynType <> + resolveExprImports patSynRHS -- | Resolve global imports resolveGlobalImports :: Global -> ImportAcc diff --git a/hs-bindgen/src/HsBindgen/Backend/TH.hs b/hs-bindgen/src/HsBindgen/Backend/TH.hs index 763ed317..56ce4b8f 100644 --- a/hs-bindgen/src/HsBindgen/Backend/TH.hs +++ b/hs-bindgen/src/HsBindgen/Backend/TH.hs @@ -173,6 +173,25 @@ mkExpr env = \case | SAlt c add hints b <- alts ] +mkPat :: Quote q => SExpr EmptyCtx -> q TH.Pat +mkPat = \case + EGlobal {} -> error "unexpected" + EFree {} -> error "cannot happen" + EBound {} -> error "cannot happen" + EFloat {} -> error "cannot happen" + EDouble {} -> error "cannot happen" + EInfix {} -> error "cannot happen" + ELam {} -> error "cannot happen" + EUnusedLam {} -> error "cannot happen" + ECase {} -> error "cannot happen" + EApp f t -> liftA2 appP (mkPat f) (mkPat t) + ECon n -> hsConP n [] + EIntegral i _ -> TH.litP (TH.IntegerL i) + where + appP :: TH.Pat -> TH.Pat -> TH.Pat + appP (TH.ConP n ts xs) p = TH.ConP n ts (xs ++ [p]) + appP _ _ = error "cannot happen" + mkType :: Quote q => Env ctx TH.Name -> SType ctx -> q TH.Type mkType env = \case TGlobal n -> TH.conT (mkGlobal n) @@ -224,6 +243,17 @@ mkDecl = \case DDerivingNewtypeInstance ty -> singleton <$> TH.standaloneDerivWithStrategyD (Just TH.NewtypeStrategy) (TH.cxt []) (mkType EmptyEnv ty) + + DPatternSynonym ps -> sequence + [ TH.patSynSigD + (hsNameToTH (patSynName ps)) + (mkType EmptyEnv (patSynType ps)) + , TH.patSynD + (hsNameToTH (patSynName ps)) + (TH.prefixPatSyn []) + TH.implBidir + (mkPat (patSynRHS ps)) + ] where simpleDecl :: TH.Name -> SExpr EmptyCtx -> q TH.Dec simpleDecl x f = TH.valD (TH.varP x) (TH.normalB $ mkExpr EmptyEnv f) [] diff --git a/hs-bindgen/src/HsBindgen/Hs/AST.hs b/hs-bindgen/src/HsBindgen/Hs/AST.hs index 55fbda31..d0193079 100644 --- a/hs-bindgen/src/HsBindgen/Hs/AST.hs +++ b/hs-bindgen/src/HsBindgen/Hs/AST.hs @@ -50,6 +50,8 @@ module HsBindgen.Hs.AST ( , StructCon (..) , ElimStruct(..) , makeElimStruct + -- ** Pattern Synonyms + , PatSyn(..) ) where import HsBindgen.C.AST qualified as C (MFun(..)) @@ -111,6 +113,7 @@ data Decl where DeclData :: SNatI n => Struct n -> Decl DeclEmpty :: HsName NsTypeConstr -> Decl DeclNewtype :: Newtype -> Decl + DeclPatSyn :: PatSyn -> Decl DeclInstance :: InstanceDecl -> Decl DeclNewtypeInstance :: TypeClass -> HsName NsTypeConstr -> Decl DeclVar :: VarDecl -> Decl @@ -205,6 +208,27 @@ data VarDeclRHSAppHead deriving stock instance Show VarDeclRHSAppHead +{------------------------------------------------------------------------------- + Pattern Synonyms +-------------------------------------------------------------------------------} + +-- | Pattern synonyms +-- +-- For now only pattern synonyms of form +-- +-- @ +-- pattern P :: T +-- pattern P = C e +-- @ +-- +data PatSyn = PatSyn + { patSynName :: HsName NsConstr + , patSynType :: HsName NsTypeConstr + , patSynConstr :: HsName NsConstr + , patSynValue :: Integer + } + deriving Show + {------------------------------------------------------------------------------- 'Storable' -------------------------------------------------------------------------------} diff --git a/hs-bindgen/src/HsBindgen/Hs/Translation.hs b/hs-bindgen/src/HsBindgen/Hs/Translation.hs index 43201abf..3bdd7676 100644 --- a/hs-bindgen/src/HsBindgen/Hs/Translation.hs +++ b/hs-bindgen/src/HsBindgen/Hs/Translation.hs @@ -148,25 +148,23 @@ enumDecs :: C.Enu -> [Hs.Decl] enumDecs e = [ Hs.DeclNewtype newtype_ , Hs.DeclInstance $ Hs.InstanceStorable hs storable - ] + ] ++ valueDecls where + cEnumName = C.enumTag e + nm@NameMangler{..} = defaultNameMangler + typeConstrCtx = TypeConstrContext cEnumName + newtypeName = mangleTypeConstrName typeConstrCtx + newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx + newtypeType = typ nm (C.enumType e) + newtype_ :: Hs.Newtype newtype_ = - let cEnumName = C.enumTag e - nm@NameMangler{..} = defaultNameMangler - typeConstrCtx = TypeConstrContext cEnumName - newtypeName = mangleTypeConstrName typeConstrCtx - newtypeConstr = mangleConstrName $ ConstrContext typeConstrCtx - newtypeField = mangleVarName $ EnumVarContext typeConstrCtx - newtypeType = typ nm (C.enumType e) + let newtypeField = mangleVarName $ EnumVarContext typeConstrCtx in Hs.Newtype {..} hs :: Hs.Struct (S Z) hs = - let cEnumName = C.enumTag e - nm@NameMangler{..} = defaultNameMangler - typeConstrCtx = TypeConstrContext cEnumName - structName = mangleTypeConstrName typeConstrCtx + let structName = mangleTypeConstrName typeConstrCtx structConstr = mangleConstrName $ ConstrContext typeConstrCtx structFields = Vec.singleton ( mangleVarName $ EnumVarContext typeConstrCtx @@ -190,6 +188,18 @@ enumDecs e = [ poke :: Idx ctx -> Int -> Idx ctx -> Hs.PokeByteOff ctx poke = Hs.PokeByteOff + valueDecls :: [Hs.Decl] + valueDecls = + [ Hs.DeclPatSyn Hs.PatSyn + { patSynName = mangleConstrName $ ConstrContext $ TypeConstrContext valueName + , patSynType = newtypeName + , patSynConstr = newtypeConstr + , patSynValue = valueValue + + } + | C.EnumValue {..} <- C.enumValues e + ] + {------------------------------------------------------------------------------- Typedef -------------------------------------------------------------------------------} @@ -212,6 +222,8 @@ typedefDecs d = [ newtypeField = mangleVarName $ EnumVarContext typeConstrCtx newtypeType = typ nm (C.typedefType d) + + {------------------------------------------------------------------------------- Macros -------------------------------------------------------------------------------} diff --git a/hs-bindgen/src/HsBindgen/Imports.hs b/hs-bindgen/src/HsBindgen/Imports.hs index f47ab573..470c162b 100644 --- a/hs-bindgen/src/HsBindgen/Imports.hs +++ b/hs-bindgen/src/HsBindgen/Imports.hs @@ -8,6 +8,7 @@ module HsBindgen.Imports ( import Data.Kind qualified +import Control.Applicative as X (liftA2) import Control.Exception as X (Exception, throwIO, bracket) import Control.Monad as X (void, ap, forM, forM_, guard, when, unless) import Control.Monad.Identity as X (Identity (..)) diff --git a/hs-bindgen/src/HsBindgen/SHs/AST.hs b/hs-bindgen/src/HsBindgen/SHs/AST.hs index 0995f3c8..c492d06d 100644 --- a/hs-bindgen/src/HsBindgen/SHs/AST.hs +++ b/hs-bindgen/src/HsBindgen/SHs/AST.hs @@ -11,6 +11,7 @@ module HsBindgen.SHs.AST ( Instance (..), Record (..), Newtype (..), + PatternSynonym (..), ) where import HsBindgen.Imports @@ -93,7 +94,7 @@ data SExpr ctx = | EBound (Idx ctx) | EFree (HsName NsVar) | ECon (HsName NsConstr) - | EIntegral Integer HsPrimType + | EIntegral Integer (Maybe HsPrimType) | EFloat Float | EDouble Double | EApp (SExpr ctx) (SExpr ctx) @@ -104,9 +105,9 @@ data SExpr ctx = deriving stock (Show) pattern EInt :: Int -> SExpr be -pattern EInt i <- EIntegral (fromInteger -> i) HsPrimCInt +pattern EInt i <- EIntegral (fromInteger -> i) (Just HsPrimCInt) where - EInt i = EIntegral (fromIntegral i) HsPrimCInt + EInt i = EIntegral (fromIntegral i) (Just HsPrimCInt) -- | Case alternatives data SAlt ctx where @@ -122,6 +123,7 @@ data SDecl = | DNewtype Newtype | DEmptyData (HsName NsTypeConstr) | DDerivingNewtypeInstance ClosedType + | DPatternSynonym PatternSynonym deriving stock (Show) type ClosedType = SType EmptyCtx @@ -160,3 +162,10 @@ data Newtype = Newtype { , newtypeType :: ClosedType } deriving stock (Show) + +data PatternSynonym = PatternSynonym + { patSynName :: HsName NsConstr + , patSynType :: ClosedType + , patSynRHS :: ClosedExpr -- TODO: This should be Pat(tern) + } + deriving stock (Show) diff --git a/hs-bindgen/src/HsBindgen/SHs/Translation.hs b/hs-bindgen/src/HsBindgen/SHs/Translation.hs index fd9654e2..1e332f26 100644 --- a/hs-bindgen/src/HsBindgen/SHs/Translation.hs +++ b/hs-bindgen/src/HsBindgen/SHs/Translation.hs @@ -30,6 +30,7 @@ translateDecl (Hs.DeclNewtype n) = translateNewtype n translateDecl (Hs.DeclInstance i) = translateInstanceDecl i translateDecl (Hs.DeclNewtypeInstance tc c) = translateNewtypeInstance tc c translateDecl (Hs.DeclVar v) = translateVarDecl v +translateDecl (Hs.DeclPatSyn ps) = translatePatSyn ps translateInstanceDecl :: Hs.InstanceDecl -> SDecl translateInstanceDecl (Hs.InstanceStorable struct i) = @@ -68,6 +69,13 @@ translateVarDecl Hs.VarDecl {..} = DVar (Just (translateSigma varDeclType)) (translateBody varDeclBody) +translatePatSyn :: Hs.PatSyn -> SDecl +translatePatSyn Hs.PatSyn {..} = DPatternSynonym PatternSynonym + { patSynName = patSynName + , patSynType = TCon patSynType + , patSynRHS = EApp (ECon patSynConstr) (EIntegral patSynValue Nothing) + } + {------------------------------------------------------------------------------- Types -------------------------------------------------------------------------------} @@ -157,7 +165,7 @@ translateBody :: Hs.VarDeclRHS ctx -> SExpr ctx translateBody (Hs.VarDeclVar x) = EBound x translateBody (Hs.VarDeclFloat f) = EFloat f translateBody (Hs.VarDeclDouble d) = EDouble d -translateBody (Hs.VarDeclIntegral i ty) = EIntegral i ty +translateBody (Hs.VarDeclIntegral i ty) = EIntegral i (Just ty) translateBody (Hs.VarDeclLambda (Hs.Lambda hint b)) = ELam hint (translateBody b) translateBody (Hs.VarDeclApp f as) = foldl' EApp (translateAppHead f) (map translateBody as)