diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,17 @@ All notable changes to this project (as seen by library users) will be documented in this file. The CHANGELOG is available on [Github](https://github.com/luc-tielen/souffle-haskell.git/CHANGELOG.md). +## [4.0.0] - 2024-01-03 + +### Added + +- Support for GHC 9.6 + +### Removed + +- Support for marshalling of Text.Short values. Only UTF8 Text values are + supported. + ## [3.5.1] - 2022-11-07 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # Souffle-haskell [![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://github.com/luc-tielen/souffle-haskell/blob/master/LICENSE) -![CI](https://github.com/luc-tielen/souffle-haskell/actions/workflows/build/badge.svg) +[![CI](https://github.com/luc-tielen/souffle-haskell/actions/workflows/build.yml/badge.svg)](https://github.com/luc-tielen/souffle-haskell/actions/workflows/build.yml) [![Hackage](https://img.shields.io/hackage/v/souffle-haskell?style=flat-square)](https://hackage.haskell.org/package/souffle-haskell) This repo provides Haskell bindings for performing analyses with the diff --git a/lib/Language/Souffle/Compiled.hs b/lib/Language/Souffle/Compiled.hs --- a/lib/Language/Souffle/Compiled.hs +++ b/lib/Language/Souffle/Compiled.hs @@ -31,7 +31,6 @@ ) where import Prelude hiding ( init ) -import Control.Monad.Except import Control.Monad.State.Strict import Data.Foldable ( traverse_ ) import Data.Functor.Identity @@ -41,11 +40,10 @@ import qualified Data.Array.IO as A import qualified Data.Array.Unsafe as A import qualified Data.ByteString as BS -import qualified Data.ByteString.Short as BSS import qualified Data.ByteString.Unsafe as BSU import qualified Data.Text as T -import qualified Data.Text.Short as TS -import qualified Data.Text.Short.Unsafe as TSU +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Internal.StrictBuilder as TB import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV @@ -154,10 +152,8 @@ {-# INLINABLE pushUInt32 #-} pushFloat = writeAsBytes {-# INLINABLE pushFloat #-} - pushString str = pushText $ TS.pack str + pushString str = pushText $ T.pack str {-# INLINABLE pushString #-} - pushTextUtf16 str = pushText $ TS.fromText str - {-# INLINABLE pushTextUtf16 #-} pushText _ = error "Fast marshalling does not support serializing string-like values." {-# INLINABLE pushText #-} @@ -169,21 +165,19 @@ {-# INLINABLE popUInt32 #-} popFloat = readAsBytes {-# INLINABLE popFloat #-} - popString = TS.unpack <$> popText + popString = T.unpack <$> popText {-# INLINABLE popString #-} - popTextUtf16 = TS.toText <$> popText - {-# INLINABLE popTextUtf16 #-} popText = do byteCount <- popUInt32 if byteCount == 0 - then pure TS.empty + then pure T.empty else do ptr <- gets castPtr bs <- liftIO $ BSU.unsafePackCStringLen (ptr, fromIntegral byteCount) put $ ptr `plusPtr` fromIntegral byteCount -- NOTE: $! is needed here to force the text value. A copy needs to - -- be made (using toShort), before the bytearray is overwritten. - pure $! TSU.fromShortByteStringUnsafe $ BSS.toShort bs + -- be made, before the bytearray is overwritten. + pure $! TB.toText $ TB.unsafeFromByteString bs {-# INLINABLE popText #-} @@ -257,12 +251,10 @@ {-# INLINABLE pushUInt32 #-} pushFloat = writeAsBytesSlow {-# INLINABLE pushFloat #-} - pushString str = pushText $ TS.pack str + pushString str = pushText $ T.pack str {-# INLINABLE pushString #-} - pushTextUtf16 str = pushText $ TS.fromText str - {-# INLINABLE pushTextUtf16 #-} pushText txt = do - let bs = TS.toByteString txt -- TODO: is it possible to get rid of this copy? + let bs = TE.encodeUtf8 txt -- TODO: is it possible to get rid of this copy? len = BS.length bs resizeBufWhenNeeded (ramDomainSize + len) pushUInt32 (fromIntegral len) @@ -447,11 +439,6 @@ toByteSize = const $ Estimated 36 {-# INLINABLE toByteSize #-} -instance ToByteSize TS.ShortText where - -- 4 for length prefix + 32 for actual string - toByteSize = const $ Estimated 36 - {-# INLINABLE toByteSize #-} - instance ToByteSize '[] where toByteSize = const $ Exact 0 {-# INLINABLE toByteSize #-} @@ -476,7 +463,6 @@ DoGetFields String = '[String] DoGetFields T.Text = '[T.Text] DoGetFields TL.Text = '[TL.Text] - DoGetFields TS.ShortText = '[TS.ShortText] DoGetFields a = GetFields (Rep a) type (++) :: [Type] -> [Type] -> [Type] @@ -510,4 +496,3 @@ pure bufData' where objCount = length fa {-# INLINABLE writeBytes #-} - diff --git a/lib/Language/Souffle/Interpreted.hs b/lib/Language/Souffle/Interpreted.hs --- a/lib/Language/Souffle/Interpreted.hs +++ b/lib/Language/Souffle/Interpreted.hs @@ -44,7 +44,6 @@ import Data.Proxy import qualified Data.Array as A import qualified Data.Text as T -import qualified Data.Text.Short as TS import qualified Data.Vector as V import Data.Word import Language.Souffle.Class @@ -210,12 +209,9 @@ pushString str = modify (str:) {-# INLINABLE pushString #-} - pushText txt = pushString (TS.unpack txt) + pushText txt = pushString (T.unpack txt) {-# INLINABLE pushText #-} - pushTextUtf16 txt = pushString (T.unpack txt) - {-# INLINABLE pushTextUtf16 #-} - instance MonadPop IMarshal where popInt32 = state $ \case [] -> error "Empty fact stack" @@ -241,15 +237,8 @@ str <- state $ \case [] -> error "Empty fact stack" (h:t) -> (h, t) - pure $ TS.pack str - {-# INLINABLE popText #-} - - popTextUtf16 = do - str <- state $ \case - [] -> error "Empty fact stack" - (h:t) -> (h, t) pure $ T.pack str - {-# INLINABLE popTextUtf16 #-} + {-# INLINABLE popText #-} popMarshalT :: IMarshal a -> [String] -> a popMarshalT (IMarshal m) = evalState m diff --git a/lib/Language/Souffle/Marshal.hs b/lib/Language/Souffle/Marshal.hs --- a/lib/Language/Souffle/Marshal.hs +++ b/lib/Language/Souffle/Marshal.hs @@ -20,7 +20,6 @@ import Data.Word import Data.Kind import qualified Data.Text as T -import qualified Data.Text.Short as TS import qualified Data.Text.Lazy as TL {- | A typeclass for serializing primitive values from Haskell to Datalog. @@ -40,9 +39,7 @@ -- | Marshals a string to the datalog side. pushString :: String -> m () -- | Marshals a UTF8-encoded Text string to the datalog side. - pushText :: TS.ShortText -> m () - -- | Marshals a UTF16-encoded Text string to the datalog side. - pushTextUtf16 :: T.Text -> m () + pushText :: T.Text -> m () {- | A typeclass for serializing primitive values from Datalog to Haskell. @@ -60,10 +57,8 @@ popFloat :: m Float -- | Unmarshals a string from the datalog side. popString :: m String - -- | Unmarshals a Text string from the datalog side. - popText :: m TS.ShortText - -- | Unmarshals a UTF16-encoded Text string from the datalog side. - popTextUtf16 :: m T.Text + -- | Unmarshals a UTF8-encoded Text string from the datalog side. + popText :: m T.Text {- | A typeclass for providing a uniform API to marshal/unmarshal values between Haskell and Souffle datalog. @@ -128,16 +123,10 @@ pop = popString {-# INLINABLE pop #-} -instance Marshal TS.ShortText where +instance Marshal T.Text where push = pushText {-# INLINABLE push #-} pop = popText - {-# INLINABLE pop #-} - -instance Marshal T.Text where - push = pushTextUtf16 - {-# INLINABLE push #-} - pop = popTextUtf16 {-# INLINABLE pop #-} instance Marshal TL.Text where diff --git a/souffle-haskell.cabal b/souffle-haskell.cabal --- a/souffle-haskell.cabal +++ b/souffle-haskell.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: souffle-haskell -version: 3.5.1 +version: 4.0.0 synopsis: Souffle Datalog bindings for Haskell description: Souffle Datalog bindings for Haskell. category: Logic Programming, Foreign Binding, Bindings @@ -18,9 +18,6 @@ license-file: LICENSE build-type: Simple extra-source-files: - README.md - CHANGELOG.md - LICENSE cbits/souffle.h cbits/souffle/CompiledSouffle.h cbits/souffle/datastructure/Brie.h @@ -69,6 +66,10 @@ cbits/souffle/utility/Types.h cbits/souffle.cpp cbits/souffle/LICENSE +extra-doc-files: + README.md + CHANGELOG.md + LICENSE source-repository head type: git @@ -96,7 +97,7 @@ OverloadedStrings ScopedTypeVariables StandaloneKindSignatures - ghc-options: -Wall -Weverything -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-import-lists -Wno-type-defaults -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -optP-Wno-nonportable-include-path -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits + ghc-options: -Wall -Weverything -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-import-lists -Wno-type-defaults -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-operator-whitespace -optP-Wno-nonportable-include-path -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits cxx-options: -std=c++17 -Wall include-dirs: cbits @@ -161,13 +162,12 @@ , process >=1.6 && <2 , profunctors >=5.6.2 && <6 , temporary >=1.3 && <2 - , text >=1.0 && <2 - , text-short >=0.1.3 && <1 + , text >=2.0.2 && <3 , vector <=1.0 + default-language: Haskell2010 if os(linux) extra-libraries: stdc++ - default-language: Haskell2010 test-suite souffle-haskell-test type: exitcode-stdio-1.0 @@ -190,7 +190,7 @@ OverloadedStrings ScopedTypeVariables StandaloneKindSignatures - ghc-options: -Wall -Weverything -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-import-lists -Wno-type-defaults -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -optP-Wno-nonportable-include-path -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits -Wno-missing-kind-signatures -Wno-operator-whitespace + ghc-options: -Wall -Weverything -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-import-lists -Wno-type-defaults -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-operator-whitespace -optP-Wno-nonportable-include-path -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits -Wno-missing-kind-signatures -Wno-operator-whitespace cxx-options: -std=c++17 -D__EMBEDDED_SOUFFLE__ include-dirs: cbits @@ -256,13 +256,12 @@ , profunctors >=5.6.2 && <6 , souffle-haskell , temporary >=1.3 && <2 - , text >=1.0 && <2 - , text-short >=0.1.3 && <1 + , text >=2.0.2 && <3 , vector <=1.0 + default-language: Haskell2010 if os(darwin) extra-libraries: c++ - default-language: Haskell2010 benchmark souffle-haskell-benchmarks type: exitcode-stdio-1.0 @@ -280,7 +279,7 @@ OverloadedStrings ScopedTypeVariables StandaloneKindSignatures - ghc-options: -Wall -Weverything -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-import-lists -Wno-type-defaults -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -optP-Wno-nonportable-include-path -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits +RTS -N1 -RTS + ghc-options: -Wall -Weverything -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-import-lists -Wno-type-defaults -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-operator-whitespace -optP-Wno-nonportable-include-path -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits +RTS -N1 -RTS cxx-options: -std=c++17 -D__EMBEDDED_SOUFFLE__ -std=c++17 -march=native include-dirs: cbits @@ -336,12 +335,12 @@ benchmarks/fixtures/bench.cpp build-depends: base >=4.12 && <5 - , criterion + , criterion ==1.* , deepseq >=1.4.4 && <2 , souffle-haskell - , text >=1.0 && <2 + , text >=2.0.2 && <3 , vector <=1.0 + default-language: Haskell2010 if os(darwin) extra-libraries: c++ - default-language: Haskell2010 diff --git a/tests/Test/Language/Souffle/AnalysisSpec.hs b/tests/Test/Language/Souffle/AnalysisSpec.hs --- a/tests/Test/Language/Souffle/AnalysisSpec.hs +++ b/tests/Test/Language/Souffle/AnalysisSpec.hs @@ -23,7 +23,7 @@ deriving stock (Eq, Show, Generic) instance Souffle.Program Path where - type ProgramFacts Path = [Edge, Reachable] + type ProgramFacts Path = '[Edge, Reachable] programName = const "path" instance Souffle.Fact Edge where diff --git a/tests/Test/Language/Souffle/CompiledSpec.hs b/tests/Test/Language/Souffle/CompiledSpec.hs --- a/tests/Test/Language/Souffle/CompiledSpec.hs +++ b/tests/Test/Language/Souffle/CompiledSpec.hs @@ -38,7 +38,7 @@ data BadPath = BadPath instance Souffle.Program BadPath where - type ProgramFacts BadPath = [Edge, Reachable] + type ProgramFacts BadPath = '[Edge, Reachable] programName = const "bad_path" diff --git a/tests/Test/Language/Souffle/InterpretedSpec.hs b/tests/Test/Language/Souffle/InterpretedSpec.hs --- a/tests/Test/Language/Souffle/InterpretedSpec.hs +++ b/tests/Test/Language/Souffle/InterpretedSpec.hs @@ -40,15 +40,15 @@ instance Souffle.Marshal Reachable instance Souffle.Program Path where - type ProgramFacts Path = [Edge, Reachable] + type ProgramFacts Path = '[Edge, Reachable] programName = const "path" instance Souffle.Program PathNoInput where - type ProgramFacts PathNoInput = [Edge, Reachable] + type ProgramFacts PathNoInput = '[Edge, Reachable] programName = const "path_no_input" instance Souffle.Program BadPath where - type ProgramFacts BadPath = [Edge, Reachable] + type ProgramFacts BadPath = '[Edge, Reachable] programName = const "bad_path" getTestTemporaryDirectory :: IO FilePath diff --git a/tests/Test/Language/Souffle/MarshalSpec.hs b/tests/Test/Language/Souffle/MarshalSpec.hs --- a/tests/Test/Language/Souffle/MarshalSpec.hs +++ b/tests/Test/Language/Souffle/MarshalSpec.hs @@ -11,7 +11,6 @@ import GHC.Generics import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import qualified Data.Text.Short as TS import Data.Text import Data.Int import Data.Word @@ -103,9 +102,6 @@ newtype LazyTextFact = LazyTextFact TL.Text deriving stock (Eq, Show, Generic) -newtype ShortTextFact = ShortTextFact TS.ShortText - deriving stock (Eq, Show, Generic) - newtype Int32Fact = Int32Fact Int32 deriving stock (Eq, Show, Generic) @@ -127,10 +123,6 @@ type FactDirection LazyTextFact = 'Souffle.InputOutput factName = const "string_fact" -instance Souffle.Fact ShortTextFact where - type FactDirection ShortTextFact = 'Souffle.InputOutput - factName = const "string_fact" - instance Souffle.Fact Int32Fact where type FactDirection Int32Fact = 'Souffle.InputOutput factName = const "number_fact" @@ -154,14 +146,13 @@ instance Souffle.Marshal StringFact instance Souffle.Marshal TextFact instance Souffle.Marshal LazyTextFact -instance Souffle.Marshal ShortTextFact instance Souffle.Marshal Int32Fact instance Souffle.Marshal Word32Fact instance Souffle.Marshal FloatFact instance Souffle.Program RoundTrip where type ProgramFacts RoundTrip = - [StringFact, TextFact, LazyTextFact, ShortTextFact, Int32Fact, Word32Fact, FloatFact, NestedNewtype, NestedRecord] + '[StringFact, TextFact, LazyTextFact, Int32Fact, Word32Fact, FloatFact, NestedNewtype, NestedRecord] programName = const "round_trip" type RoundTripAction @@ -191,7 +182,7 @@ instance Souffle.Program EdgeCases where type ProgramFacts EdgeCases = - [ EmptyStrings String, EmptyStrings T.Text, EmptyStrings TL.Text + '[ EmptyStrings String, EmptyStrings T.Text, EmptyStrings TL.Text , LongStrings String, LongStrings T.Text, LongStrings TL.Text , Unicode String, Unicode T.Text, Unicode TL.Text , NoStrings Void @@ -273,12 +264,6 @@ it "can serialize and deserialize strict Text values" $ hedgehog $ do str <- forAll $ Gen.text (Range.linear 0 10) Gen.unicode let fact = TextFact str - fact' <- run fact - fact === fact' - - it "can serialize and deserialize short Text values" $ hedgehog $ do - str <- forAll $ Gen.text (Range.linear 0 10) Gen.unicode - let fact = ShortTextFact (TS.fromText str) fact' <- run fact fact === fact'