diff --git a/.gitignore b/.gitignore index 5127552..aefdffb 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ cbits/*.o upload-docs.sh *.csv .direnv/ +.vscode diff --git a/.hlint.yaml b/.hlint.yaml index 402fe71..81dd844 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -1,75 +1,32 @@ -# HLint configuration file -# https://github.com/ndmitchell/hlint -########################## - -# This file contains a template configuration file, which is typically -# placed as .hlint.yaml in the root of your project - - -# Specify additional command line arguments -# -# - arguments: [--color, --cpp-simple, -XQuasiQuotes] - - -# Control which extensions/flags/modules/functions can be used -# -# - extensions: -# - default: false # all extension are banned by default -# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used -# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module -# -# - flags: -# - {name: -w, within: []} # -w is allowed nowhere -# -# - modules: -# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' -# - {name: Control.Arrow, within: []} # Certain modules are banned entirely -# -# - functions: -# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules - - -# Add custom hints for this project -# -# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" -# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} - - -# Turn on hints that are off by default -# -# Ban "module X(module X) where", to require a real export list -# - warn: {name: Use explicit module export list} -# -# Replace a $ b $ c with a . b $ c -# - group: {name: dollar, enabled: true} -# -# Generalise map to fmap, ++ to <> -# - group: {name: generalise, enabled: true} - - -# Ignore some builtin hints -# - ignore: {name: Use let} -# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules -- ignore: - name: Reduce duplication - within: - - Test.Language.Souffle.CompiledSpec - - Test.Language.Souffle.InterpretedSpec - - Language.Souffle.Interpreted -- ignore: - name: Monoid law, right identity - within: - - Test.Language.Souffle.CompiledSpec - - Test.Language.Souffle.InterpretedSpec -- ignore: - name: Use newtype instead of data - within: - - Language.Souffle.Compiled - - -# Define some custom infix operators -# - fixity: infixr 3 ~^#^~ - - -# To generate a suitable file for HLint do: -# $ hlint --default > .hlint.yaml +# These are just too annoying +- ignore: { name: Redundant do } +- ignore: { name: Redundant bracket } +- ignore: { name: Redundant lambda } +- ignore: { name: Redundant $ } +- ignore: { name: Redundant flip } +- ignore: { name: Redundant <$> } +- ignore: { name: Redundant pure } +- ignore: { name: Move brackets to avoid $ } +- ignore: { name: Use tuple-section } +- ignore: { name: Avoid lambda using `infix` } + +# Losing variable names can be not-nice +- ignore: { name: Eta reduce } +- ignore: { name: Avoid lambda } + +# Humans know better +- ignore: { name: Use camelCase } +- ignore: { name: Use const } +- ignore: { name: Use section } +- ignore: { name: Use if } +- ignore: { name: Use notElem } +- ignore: { name: Use fromMaybe } +- ignore: { name: Use maybe } +- ignore: { name: Use fmap } +- ignore: { name: Use foldl } +- ignore: { name: "Use :" } +- ignore: { name: Use ++ } +- ignore: { name: Use || } +- ignore: { name: Use && } +- ignore: { name: 'Use ?~' } +- ignore: { name: Use <$> } diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..85c74fe --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,409 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true + # + # # When to break the "where". + # # Possible values: + # # - exports: only break when there is an explicit export list. + # # - single: only break when the export list counts more than one export. + # # - inline: only break when the export list is too long. This is + # # determined by the `columns` setting. Not applicable when the export + # # list contains comments as newlines will be required. + # # - always: always break before the "where". + # break_where: exports + # + # # Where to put open bracket + # # Possible values: + # # - same_line: put open bracket on the same line as the module name, before the + # # comment of the module + # # - next_line: put open bracket on the next line, after module comment + # open_bracket: next_line + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + # - records: + # # How to format equals sign between type constructor and data constructor. + # # Possible values: + # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + # equals: "indent 2" + # + # # How to format first field of each record constructor. + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # first_field: "indent 2" + # + # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + # field_comment: 2 + # + # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. + # via: "indent 2" + # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # + # # Whether or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Post qualify option moves any qualifies found in import declarations + # to the end of the declaration. This also adjust padding for any + # unqualified import declarations. + # + # - true: Qualified as is moved to the end of the + # declaration. + # + # > import Data.Bar + # > import Data.Foo qualified as F + # + # - false: Qualified remains in the default location and unqualified + # imports are padded to align with qualified imports. + # + # > import Data.Bar + # > import qualified Data.Foo as F + # + # Default: false + post_qualify: false + + # Automatically group imports based on their module names, with + # a blank line separating each group. Groups are ordered in + # alphabetical order. + # + # By default, this groups by the first part of each module's + # name (Control.* will be grouped together, Data.*... etc), but + # this can be configured with the group_patterns setting. + # + # When enabled, this rewrites existing blank lines and groups. + # + # - true: Group imports by the first part of the module name. + # + # > import Control.Applicative + # > import Control.Monad + # > import Control.Monad.MonadError + # > + # > import Data.Functor + # + # - false: Keep import groups as-is (still sorting and + # formatting the imports within each group) + # + # > import Control.Monad + # > import Data.Functor + # > + # > import Control.Applicative + # > import Control.Monad.MonadError + # + # Default: false + group_imports: true + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-# LANGUAGE #-}'. + # + # - vertical_compact: Similar to vertical, but use only one language pragma. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + - tabs: + # Number of spaces to use for each tab. Default: 8, as specified by the + # Haskell report. + spaces: 4 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 120 # null + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true \ No newline at end of file diff --git a/README.md b/README.md index 606e7ad..c05d0c0 100644 --- a/README.md +++ b/README.md @@ -77,13 +77,13 @@ data Edge = Edge String String -- By making a data type an instance of Fact, we give Haskell the -- necessary information to bind to the datalog fact. deriving Souffle.Fact - via Souffle.FactOptions Edge "edge" 'Souffle.Input + via Souffle.FactOptions Edge "edge" Souffle.Input data Reachable = Reachable String String deriving stock (Eq, Show, Generic) deriving anyclass Souffle.Marshal deriving Souffle.Fact - via Souffle.FactOptions Reachable "reachable" 'Souffle.Output + via Souffle.FactOptions Reachable "reachable" Souffle.Output main :: IO () diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 200a2e5..0000000 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs index b233a4b..86b7e97 100644 --- a/benchmarks/bench.hs +++ b/benchmarks/bench.hs @@ -1,75 +1,96 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleContexts #-} -module Main ( main ) where - -import Criterion.Main +module Main (main) where + +import Control.Applicative (Applicative (..)) +import Control.DeepSeq (NFData) +import Control.Monad (replicateM_) +import Control.Monad.IO.Class (MonadIO (..)) + +import Criterion.Main (Benchmark, bench, bgroup, defaultMain, nfIO) + +import Data.Function (const, ($)) +import Data.Int (Int, Int32) +import Data.List (List, (++)) +import Data.Maybe (Maybe (..)) +import Data.String (String) +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Word (Word32) + +import GHC.Float (Float) +import GHC.Generics (Generic) +import GHC.Real (fromIntegral) +import GHC.Tuple (Unit) + import qualified Language.Souffle.Compiled as S -import qualified Data.Text as T -import qualified Data.Vector as V -import GHC.Generics -import Data.Word -import Data.Int -import Control.Monad -import Control.Monad.IO.Class -import Control.DeepSeq + +import System.IO (IO, putStrLn) data Benchmarks = Benchmarks data NumbersFact = NumbersFact Word32 Int32 Float - deriving (Generic, NFData) + deriving stock (Generic) + deriving anyclass (NFData) data StringsFact = StringsFact Word32 T.Text Int32 Float - deriving (Generic, NFData) + deriving stock (Generic) + deriving anyclass (NFData) newtype FromDatalogFact = FromDatalogFact Int32 - deriving (Generic, NFData) + deriving stock (Generic) + deriving anyclass (NFData) data FromDatalogStringFact = FromDatalogStringFact Int32 T.Text - deriving (Generic, NFData) + deriving stock (Generic) + deriving anyclass (NFData) instance S.Program Benchmarks where - type ProgramFacts Benchmarks = - '[NumbersFact, StringsFact, FromDatalogFact, FromDatalogStringFact] + type ProgramFacts Benchmarks = [NumbersFact, StringsFact, FromDatalogFact, FromDatalogStringFact] + + programName :: Benchmarks -> String programName = const "bench" instance S.Fact NumbersFact where type FactDirection NumbersFact = 'S.InputOutput - factName = const "numbers_fact" + + factName :: String + factName = "numbers_fact" instance S.Fact StringsFact where type FactDirection StringsFact = 'S.InputOutput - factName = const "strings_fact" + + factName :: String + factName = "strings_fact" instance S.Fact FromDatalogFact where type FactDirection FromDatalogFact = 'S.InputOutput - factName = const "from_datalog_fact" + + factName :: String + factName = "from_datalog_fact" instance S.Fact FromDatalogStringFact where type FactDirection FromDatalogStringFact = 'S.InputOutput - factName = const "from_datalog_string_fact" + + factName :: String + factName = "from_datalog_string_fact" instance S.Marshal NumbersFact instance S.Marshal StringsFact instance S.Marshal FromDatalogFact instance S.Marshal FromDatalogStringFact - -- TODO: fix cases with larger numbers (crashes due to large memory allocations?) -main :: IO () +main :: IO Unit main = defaultMain $ roundTripBenchmarks ++ serializationBenchmarks ++ deserializationBenchmarks -roundTripBenchmarks :: [Benchmark] +roundTripBenchmarks :: List Benchmark roundTripBenchmarks = [ bgroup "round trip facts (without strings)" [ bench "1" $ nfIO $ roundTrip $ mkVec 1 @@ -104,7 +125,7 @@ roundTrip :: (S.ContainsInputFact Benchmarks a, S.ContainsOutputFact Benchmarks => V.Vector a -> IO (V.Vector a) roundTrip vec = S.runSouffle Benchmarks $ \case Nothing -> do - liftIO $ print "Failed to load roundtrip benchmarks!" + liftIO $ putStrLn "Failed to load roundtrip benchmarks!" pure V.empty Just prog -> do S.addFacts prog vec @@ -112,41 +133,41 @@ roundTrip vec = S.runSouffle Benchmarks $ \case S.getFacts prog -serializeNumbers :: Int -> IO () +serializeNumbers :: Int -> IO Unit serializeNumbers iterationCount = S.runSouffle Benchmarks $ \case - Nothing -> liftIO $ print "Failed to load serialize benchmarks!" + Nothing -> liftIO $ putStrLn "Failed to load serialize benchmarks!" Just prog -> replicateM_ iterationCount $ S.addFacts prog vec -- No run needed where vec = V.generate 100 $ \i -> NumbersFact (fromIntegral i) (-42) 3.14 -deserializeNumbers :: Int -> IO () +deserializeNumbers :: Int -> IO Unit deserializeNumbers iterationCount = S.runSouffle Benchmarks $ \case - Nothing -> liftIO $ print "Failed to load deserialize benchmarks!" + Nothing -> liftIO $ putStrLn "Failed to load deserialize benchmarks!" Just prog -> do S.run prog replicateM_ iterationCount $ do fs <- S.getFacts prog pure (fs :: V.Vector FromDatalogFact) -serializeWithStrings :: Int -> IO () +serializeWithStrings :: Int -> IO Unit serializeWithStrings iterationCount = S.runSouffle Benchmarks $ \case - Nothing -> liftIO $ print "Failed to load serialize benchmarks!" + Nothing -> liftIO $ putStrLn "Failed to load serialize benchmarks!" Just prog -> replicateM_ iterationCount $ S.addFacts prog vec -- No run needed where vec = V.generate 100 $ \i -> StringsFact (fromIntegral i) "abcdef" (-42) 3.14 -deserializeWithStrings :: Int -> IO () +deserializeWithStrings :: Int -> IO Unit deserializeWithStrings iterationCount = S.runSouffle Benchmarks $ \case - Nothing -> liftIO $ print "Failed to load deserialize benchmarks!" + Nothing -> liftIO $ putStrLn "Failed to load deserialize benchmarks!" Just prog -> do S.run prog replicateM_ iterationCount $ do fs <- S.getFacts prog pure (fs :: V.Vector FromDatalogStringFact) -serializationBenchmarks :: [Benchmark] +serializationBenchmarks :: List Benchmark serializationBenchmarks = [ bgroup "serializing facts (without strings)" [ bench "1" $ nfIO $ serializeNumbers 1 @@ -164,7 +185,7 @@ serializationBenchmarks = ] ] -deserializationBenchmarks :: [Benchmark] +deserializationBenchmarks :: List Benchmark deserializationBenchmarks = [ bgroup "deserializing facts (without strings)" [ bench "1" $ nfIO $ deserializeNumbers 1 diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..bf3c58e --- /dev/null +++ b/cabal.project @@ -0,0 +1,4 @@ +packages: * + +tests: True +benchmarks: True diff --git a/cbits/souffle/CompiledSouffle.h b/cbits/souffle/CompiledSouffle.h index 78f03b7..f514fe4 100644 --- a/cbits/souffle/CompiledSouffle.h +++ b/cbits/souffle/CompiledSouffle.h @@ -248,10 +248,16 @@ class t_info { context createContext() { return context(); } - class iterator : public std::iterator> { + class iterator { typename std::vector>::const_iterator it; public: + using iterator_category = std::forward_iterator_tag; + using value_type = Tuple; + using difference_type = std::ptrdiff_t; + using pointer = value_type*; + using reference = value_type&; + iterator(const typename std::vector::const_iterator& o) : it(o) {} const t_tuple operator*() { @@ -329,12 +335,18 @@ struct t_eqrel { using t_tuple = Tuple; using t_ind = EquivalenceRelation; t_ind ind; - class iterator_0 : public std::iterator { + class iterator_0 { using nested_iterator = typename t_ind::iterator; nested_iterator nested; t_tuple value; public: + using iterator_category = std::forward_iterator_tag; + using value_type = t_tuple; + using difference_type = std::ptrdiff_t; + using pointer = value_type*; + using reference = value_type&; + iterator_0(const nested_iterator& iter) : nested(iter), value(*iter) {} iterator_0(const iterator_0& other) = default; iterator_0& operator=(const iterator_0& other) = default; @@ -356,12 +368,18 @@ struct t_eqrel { return *this; } }; - class iterator_1 : public std::iterator { + class iterator_1 { using nested_iterator = typename t_ind::iterator; nested_iterator nested; t_tuple value; public: + using iterator_category = std::forward_iterator_tag; + using value_type = t_tuple; + using difference_type = std::ptrdiff_t; + using pointer = value_type*; + using reference = value_type&; + iterator_1(const nested_iterator& iter) : nested(iter), value(reorder(*iter)) {} iterator_1(const iterator_1& other) = default; iterator_1& operator=(const iterator_1& other) = default; diff --git a/cbits/souffle/datastructure/BTreeDelete.h b/cbits/souffle/datastructure/BTreeDelete.h index 3f9391b..a717f28 100644 --- a/cbits/souffle/datastructure/BTreeDelete.h +++ b/cbits/souffle/datastructure/BTreeDelete.h @@ -904,8 +904,14 @@ class btree_delete { /** * The iterator type to be utilized for scanning through btree instances. */ - class iterator : public std::iterator { + class iterator { public: + using iterator_category = std::bidirectional_iterator_tag; + using value_type = Key; + using difference_type = std::ptrdiff_t; + using pointer = value_type*; + using reference = value_type&; + // a pointer to the node currently referred to // node const* cur; node* cur; @@ -913,12 +919,6 @@ class btree_delete { // the index of the element currently addressed within the referenced node field_index_type pos = 0; - using iterator_category = std::forward_iterator_tag; - using value_type = Key; - using difference_type = ptrdiff_t; - using pointer = value_type*; - using reference = value_type&; - // default constructor -- creating an end-iterator iterator() : cur(nullptr) {} diff --git a/cbits/souffle/datastructure/PiggyList.h b/cbits/souffle/datastructure/PiggyList.h index 3d8d2f1..f56beff 100644 --- a/cbits/souffle/datastructure/PiggyList.h +++ b/cbits/souffle/datastructure/PiggyList.h @@ -252,11 +252,17 @@ class PiggyList { container_size = 0; } - class iterator : std::iterator { + class iterator { std::size_t cIndex = 0; PiggyList* bl; public: + using iterator_category = std::forward_iterator_tag; + using value_type = T; + using difference_type = std::ptrdiff_t; + using pointer = value_type*; + using reference = value_type&; + // default ctor, to silence iterator() = default; diff --git a/cbits/souffle/datastructure/Table.h b/cbits/souffle/datastructure/Table.h index 08627d3..678d9fb 100644 --- a/cbits/souffle/datastructure/Table.h +++ b/cbits/souffle/datastructure/Table.h @@ -49,11 +49,17 @@ class Table { std::size_t count = 0; public: - class iterator : public std::iterator { + class iterator { Block* block; unsigned pos; public: + using iterator_category = std::forward_iterator_tag; + using value_type = T; + using difference_type = std::ptrdiff_t; + using pointer = value_type*; + using reference = value_type&; + iterator(Block* block = nullptr, unsigned pos = 0) : block(block), pos(pos) {} iterator(const iterator&) = default; diff --git a/lib/Language/Souffle/Analysis.hs b/lib/Language/Souffle/Analysis.hs index 62bb246..da807cd 100644 --- a/lib/Language/Souffle/Analysis.hs +++ b/lib/Language/Souffle/Analysis.hs @@ -1,27 +1,33 @@ -{-# LANGUAGE UndecidableInstances, TupleSections #-} - -{- | This module provides an 'Analysis' type for combining multiple Datalog - analyses together. Composition of analyses is done via the various - type-classes that are implemented for this type. For a longer explanation - of how the 'Analysis' type works, see this - . - - If you are just starting out using this library, you are probably better - of taking a look at the "Language.Souffle.Interpreted" module instead to - start interacting with a single Datalog program. --} +-- | This module provides an 'Analysis' type for combining multiple Datalog +-- analyses together. Composition of analyses is done via the various +-- type-classes that are implemented for this type. For a longer explanation +-- of how the 'Analysis' type works, see this +-- . +-- +-- If you are just starting out using this library, you are probably better +-- of taking a look at the "Language.Souffle.Interpreted" module instead to +-- start interacting with a single Datalog program. module Language.Souffle.Analysis ( Analysis , mkAnalysis , execAnalysis ) where -import Prelude hiding (id, (.)) -import Data.Kind (Type) -import Control.Category -import Control.Monad -import Control.Arrow -import Data.Profunctor +import Control.Applicative (Applicative (pure, (*>), (<*>))) +import Control.Arrow (Arrow (..), ArrowChoice (..)) +import Control.Category (Category (..)) +import Control.Monad (Monad, (>=>)) + +import Data.Either (Either (..)) +import Data.Function (const, ($)) +import Data.Functor (Functor (..), (<$>)) +import Data.Kind (Type) +import Data.Monoid (Monoid (..)) +import Data.Profunctor (Choice (..), Profunctor (..), Strong (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Tuple (fst, snd) + +import GHC.Tuple (Tuple2, Unit) -- | Data type used to compose multiple Datalog programs. Composition is mainly -- done via the various type-classes implemented for this type. @@ -34,11 +40,12 @@ import Data.Profunctor -- types of the analysis. type Analysis :: (Type -> Type) -> Type -> Type -> Type data Analysis m a b - = Analysis (a -> m ()) (m ()) (a -> m b) + = Analysis (a -> m Unit) (m Unit) (a -> m b) +type role Analysis representational representational nominal -- | Creates an 'Analysis' value. -mkAnalysis :: (a -> m ()) -- ^ Function for finding facts used by the 'Analysis'. - -> m () -- ^ Function for actually running the 'Analysis'. +mkAnalysis :: (a -> m Unit) -- ^ Function for finding facts used by the 'Analysis'. + -> m Unit -- ^ Function for actually running the 'Analysis'. -> m b -- ^ Function for retrieving the 'Analysis' results from Souffle. -> Analysis m a b mkAnalysis f r g = Analysis f r (const g) @@ -50,36 +57,44 @@ execAnalysis (Analysis f r g) a = f a *> r *> g a {-# INLINABLE execAnalysis #-} instance Functor m => Functor (Analysis m a) where + fmap :: Functor m => (a1 -> b) -> Analysis m a a1 -> Analysis m a b fmap func (Analysis f r g) = Analysis f r (fmap func <$> g) {-# INLINABLE fmap #-} instance Functor m => Profunctor (Analysis m) where + lmap :: Functor m => (a -> b) -> Analysis m b c -> Analysis m a c lmap fn (Analysis f r g) = Analysis (lmap fn f) r (lmap fn g) {-# INLINABLE lmap #-} + rmap :: Functor m => (b -> c) -> Analysis m a b -> Analysis m a c rmap = fmap {-# INLINABLE rmap #-} -instance (Monoid (m ()), Applicative m) => Applicative (Analysis m a) where +instance (Monoid (m Unit), Applicative m) => Applicative (Analysis m a) where + pure :: (Monoid (m Unit), Applicative m) => a1 -> Analysis m a a1 pure a = Analysis mempty mempty (const $ pure a) {-# INLINABLE pure #-} + (<*>) :: (Monoid (m Unit), Applicative m) => Analysis m a (a1 -> b) -> Analysis m a a1 -> Analysis m a b Analysis f1 r1 g1 <*> Analysis f2 r2 g2 = Analysis (f1 <> f2) (r1 <> r2) (\a -> g1 a <*> g2 a) {-# INLINABLE (<*>) #-} -instance (Semigroup (m ()), Semigroup (m b)) => Semigroup (Analysis m a b) where +instance (Semigroup (m Unit), Semigroup (m b)) => Semigroup (Analysis m a b) where + (<>) :: (Semigroup (m Unit), Semigroup (m b)) => Analysis m a b -> Analysis m a b -> Analysis m a b Analysis f1 r1 g1 <> Analysis f2 r2 g2 = Analysis (f1 <> f2) (r1 <> r2) (g1 <> g2) {-# INLINABLE (<>) #-} -instance (Monoid (m ()), Monoid (m b)) => Monoid (Analysis m a b) where +instance (Monoid (m Unit), Monoid (m b)) => Monoid (Analysis m a b) where + mempty :: (Monoid (m Unit), Monoid (m b)) => Analysis m a b mempty = Analysis mempty mempty mempty {-# INLINABLE mempty #-} -instance (Monoid (m ()), Monad m) => Category (Analysis m) where +instance (Monoid (m Unit), Monad m) => Category (Analysis m) where + id :: (Monoid (m Unit), Monad m) => Analysis m a a id = Analysis mempty mempty pure {-# INLINABLE id #-} @@ -91,15 +106,18 @@ instance (Monoid (m ()), Monad m) => Category (Analysis m) where {-# INLINABLE (.) #-} instance Functor m => Strong (Analysis m) where + first' :: Functor m => Analysis m a b -> Analysis m (Tuple2 a c) (Tuple2 b c) first' (Analysis f r g) = Analysis (f . fst) r $ \(b, d) -> (,d) <$> g b {-# INLINABLE first' #-} + second' :: Functor m => Analysis m a b -> Analysis m (Tuple2 c a) (Tuple2 c b) second' (Analysis f r g) = Analysis (f . snd) r $ \(d, b) -> (d,) <$> g b {-# INLINABLE second' #-} instance Applicative m => Choice (Analysis m) where + left' :: Applicative m => Analysis m a b -> Analysis m (Either a c) (Either b c) left' (Analysis f r g) = Analysis f' r g' where f' = \case @@ -110,6 +128,7 @@ instance Applicative m => Choice (Analysis m) where Right d -> pure $ Right d {-# INLINABLE left' #-} + right' :: Applicative m => Analysis m a b -> Analysis m (Either c a) (Either c b) right' (Analysis f r g) = Analysis f' r g' where f' = \case @@ -120,16 +139,20 @@ instance Applicative m => Choice (Analysis m) where Right b -> Right <$> g b {-# INLINABLE right' #-} -instance (Monad m, Monoid (m ()), Category (Analysis m)) => Arrow (Analysis m) where +instance (Monad m, Monoid (m Unit), Category (Analysis m)) => Arrow (Analysis m) where + arr :: (Monad m, Monoid (m Unit), Category (Analysis m)) => (b -> c) -> Analysis m b c arr f = Analysis mempty mempty (pure . f) {-# INLINABLE arr #-} + first :: (Monad m, Monoid (m Unit), Category (Analysis m)) => Analysis m b c -> Analysis m (Tuple2 b d) (Tuple2 c d) first = first' {-# INLINABLE first #-} + second :: (Monad m, Monoid (m Unit), Category (Analysis m)) => Analysis m b c -> Analysis m (Tuple2 d b) (Tuple2 d c) second = second' {-# INLINABLE second #-} + (***) :: (Monad m, Monoid (m Unit), Category (Analysis m)) => Analysis m b c -> Analysis m b' c' -> Analysis m (Tuple2 b b') (Tuple2 c c') Analysis f1 r1 g1 *** Analysis f2 r2 g2 = Analysis (\(b, b') -> f1 b *> f2 b') (r1 <> r2) $ \(b, b') -> do c <- g1 b @@ -137,17 +160,21 @@ instance (Monad m, Monoid (m ()), Category (Analysis m)) => Arrow (Analysis m) w pure (c, c') {-# INLINABLE (***) #-} + (&&&) :: (Monad m, Monoid (m Unit), Category (Analysis m)) => Analysis m b c -> Analysis m b c' -> Analysis m b (Tuple2 c c') Analysis f1 r1 g1 &&& Analysis f2 r2 g2 = Analysis (f1 <> f2) (r1 <> r2) $ \b -> (,) <$> g1 b <*> g2 b {-# INLINABLE (&&&) #-} -instance (Monad m, Monoid (m ())) => ArrowChoice (Analysis m) where +instance (Monad m, Monoid (m Unit)) => ArrowChoice (Analysis m) where + left :: (Monad m, Monoid (m Unit)) => Analysis m b c -> Analysis m (Either b d) (Either c d) left = left' {-# INLINABLE left #-} + right :: (Monad m, Monoid (m Unit)) => Analysis m b c -> Analysis m (Either d b) (Either d c) right = right' {-# INLINABLE right #-} + (+++) :: (Monad m, Monoid (m Unit)) => Analysis m b c -> Analysis m b' c' -> Analysis m (Either b b') (Either c c') Analysis f1 r1 g1 +++ Analysis f2 r2 g2 = Analysis f' (r1 <> r2) g' where f' = \case diff --git a/lib/Language/Souffle/Class.hs b/lib/Language/Souffle/Class.hs index cf1588f..340c48a 100644 --- a/lib/Language/Souffle/Class.hs +++ b/lib/Language/Souffle/Class.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DataKinds, UndecidableInstances, FlexibleContexts #-} -{-# LANGUAGE TypeFamilies, TypeOperators, TypeApplications #-} - -- | This module provides the top level API for Souffle related operations. -- It makes use of Haskell's powerful typesystem to make certain invalid states -- impossible to represent. It does this with a small type level DSL for @@ -27,21 +24,35 @@ module Language.Souffle.Class , MonadSouffleFileIO(..) ) where -import Prelude hiding ( init ) - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Writer -import qualified Control.Monad.RWS.Strict as StrictRWS -import qualified Control.Monad.RWS.Lazy as LazyRWS +import Control.Monad (Monad) +import Control.Monad.Except (ExceptT) +import Control.Monad.Reader (MonadTrans (..), ReaderT) +import qualified Control.Monad.RWS.Lazy as LazyRWS +import qualified Control.Monad.RWS.Strict as StrictRWS +import qualified Control.Monad.State.Lazy as LazyState import qualified Control.Monad.State.Strict as StrictState -import qualified Control.Monad.State.Lazy as LazyState -import Data.Proxy -import Data.Kind -import Data.Word -import GHC.TypeLits -import qualified Language.Souffle.Marshal as Marshal +import Control.Monad.Writer (WriterT) + +import Data.Eq (Eq) +import Data.Foldable (Foldable) +import Data.Function (const, ($), (.)) +import Data.Functor ((<$>)) +import Data.Kind (Constraint, Type) +import Data.List (List) +import Data.Maybe (Maybe) +import Data.Monoid (Monoid) +import Data.String (String) +import Data.Word (Word64) + +import GHC.Classes (CTuple2, CUnit) +import GHC.Tuple (Unit) +import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolSing) +import qualified Language.Souffle.Marshal as Marshal + +import System.FilePath (FilePath) + +import Text.Show (Show(..)) -- | A helper type family for checking if a specific Souffle `Program` contains -- a certain `Fact`. Additionally, it also checks if the fact is marked as @@ -49,7 +60,7 @@ import qualified Language.Souffle.Marshal as Marshal -- user-friendly type error if these conditions are not met. type ContainsInputFact :: Type -> Type -> Constraint type family ContainsInputFact prog fact where - ContainsInputFact prog fact = (ContainsFact prog fact, IsInput fact (FactDirection fact)) + ContainsInputFact prog fact = CTuple2 (ContainsFact prog fact) (IsInput fact (FactDirection fact)) -- | A helper type family for checking if a specific Souffle `Program` contains -- a certain `Fact`. Additionally, it also checks if the fact is marked as @@ -57,33 +68,33 @@ type family ContainsInputFact prog fact where -- user-friendly type error if these conditions are not met. type ContainsOutputFact :: Type -> Type -> Constraint type family ContainsOutputFact prog fact where - ContainsOutputFact prog fact = (ContainsFact prog fact, IsOutput fact (FactDirection fact)) + ContainsOutputFact prog fact = CTuple2 (ContainsFact prog fact) (IsOutput fact (FactDirection fact)) type IsInput :: Type -> Direction -> Constraint type family IsInput fact dir where - IsInput _ 'Input = () - IsInput _ 'InputOutput = () - IsInput fact dir = TypeError - ( 'Text "You tried to use an " ':<>: 'ShowType (FormatDirection dir) ':<>: 'Text " fact of type " ':<>: 'ShowType fact ':<>: 'Text " as an input." - ':$$: 'Text "Possible solution: change the FactDirection of " ':<>: 'ShowType fact - ':<>: 'Text " to either 'Input' or 'InputOutput'." + IsInput _ Input = CUnit + IsInput _ InputOutput = CUnit + IsInput fact dir = TypeError + ( Text "You tried to use an " :<>: ShowType (FormatDirection dir) :<>: Text " fact of type " :<>: ShowType fact :<>: Text " as an input." + :$$: Text "Possible solution: change the FactDirection of " :<>: ShowType fact + :<>: Text " to either 'Input' or 'InputOutput'." ) type IsOutput :: Type -> Direction -> Constraint type family IsOutput fact dir where - IsOutput _ 'Output = () - IsOutput _ 'InputOutput = () - IsOutput fact dir = TypeError - ( 'Text "You tried to use an " ':<>: 'ShowType (FormatDirection dir) ':<>: 'Text " fact of type " ':<>: 'ShowType fact ':<>: 'Text " as an output." - ':$$: 'Text "Possible solution: change the FactDirection of " ':<>: 'ShowType fact - ':<>: 'Text " to either 'Output' or 'InputOutput'." + IsOutput _ Output = CUnit + IsOutput _ InputOutput = CUnit + IsOutput fact dir = TypeError + ( Text "You tried to use an " :<>: ShowType (FormatDirection dir) :<>: Text " fact of type " :<>: ShowType fact :<>: Text " as an output." + :$$: Text "Possible solution: change the FactDirection of " :<>: ShowType fact + :<>: Text " to either 'Output' or 'InputOutput'." ) type FormatDirection :: Direction -> Symbol type family FormatDirection dir where - FormatDirection 'Output = "output" - FormatDirection 'Input = "input" - FormatDirection 'Internal = "internal" + FormatDirection Output = "output" + FormatDirection Input = "input" + FormatDirection Internal = "internal" -- | A helper type family for checking if a specific Souffle `Program` contains -- a certain `Fact`. This constraint will generate a user-friendly type error @@ -93,17 +104,17 @@ type family ContainsFact prog fact where ContainsFact prog fact = CheckContains prog (ProgramFacts prog) fact -type CheckContains :: Type -> [Type] -> Type -> Constraint +type CheckContains :: Type -> List Type -> Type -> Constraint type family CheckContains prog facts fact :: Constraint where - CheckContains prog '[] fact = - TypeError ('Text "You tried to perform an action with a fact of type '" ':<>: 'ShowType fact - ':<>: 'Text "' for program '" ':<>: 'ShowType prog ':<>: 'Text "'." - ':$$: 'Text "The program contains the following facts: " ':<>: 'ShowType (ProgramFacts prog) ':<>: 'Text "." - ':$$: 'Text "It does not contain fact: " ':<>: 'ShowType fact ':<>: 'Text "." - ':$$: 'Text "You can fix this error by adding the type '" ':<>: 'ShowType fact - ':<>: 'Text "' to the ProgramFacts type in the Program instance for " ':<>: 'ShowType prog ':<>: 'Text ".") - CheckContains _ (a ': _) a = () - CheckContains prog (_ ': as) b = CheckContains prog as b + CheckContains prog [] fact = + TypeError (Text "You tried to perform an action with a fact of type '" :<>: ShowType fact + :<>: Text "' for program '" :<>: ShowType prog :<>: Text "'." + :$$: Text "The program contains the following facts: " :<>: ShowType (ProgramFacts prog) :<>: Text "." + :$$: Text "It does not contain fact: " :<>: ShowType fact :<>: Text "." + :$$: Text "You can fix this error by adding the type '" :<>: ShowType fact + :<>: Text "' to the ProgramFacts type in the Program instance for " :<>: ShowType prog :<>: Text ".") + CheckContains _ (a : _) a = CUnit + CheckContains prog (_ : as) b = CheckContains prog as b -- | A typeclass for describing a datalog program. -- @@ -114,14 +125,14 @@ type family CheckContains prog facts fact :: Constraint where -- data Path = Path -- Handle for the datalog program -- -- instance Program Path where --- type ProgramFacts Path = '[Edge, Reachable] +-- type ProgramFacts Path = [Edge, Reachable] -- programName = const "path" -- @ type Program :: Type -> Constraint class Program a where -- | A type level list of facts that belong to this program. -- This list is used to check that only known facts are added to a program. - type ProgramFacts a :: [Type] + type ProgramFacts a :: List Type -- | Function for obtaining the name of a Datalog program. -- This has to be the same as the name of the .dl file (minus the extension). @@ -137,18 +148,19 @@ class Program a where -- @ -- data Path = Path -- deriving Souffle.Program --- via Souffle.ProgramOptions Path "path" '[Edge, Reachable] +-- via Souffle.ProgramOptions Path "path" [Edge, Reachable] -- @ -- -- See also: 'FactOptions'. -type ProgramOptions :: Type -> Symbol -> [Type] -> Type -newtype ProgramOptions prog progName facts - = ProgramOptions prog +type ProgramOptions :: Type -> Symbol -> List Type -> Type +newtype ProgramOptions prog progName facts = ProgramOptions prog +type role ProgramOptions representational phantom phantom instance KnownSymbol progName => Program (ProgramOptions prog progName facts) where type ProgramFacts (ProgramOptions _ _ facts) = facts - programName = const $ symbolVal (Proxy @progName) + programName :: KnownSymbol progName => ProgramOptions prog progName facts -> String + programName = const $ show $ symbolSing @progName {-# INLINABLE programName #-} -- | A typeclass for data types representing a fact in datalog. @@ -169,9 +181,7 @@ class Marshal.Marshal a => Fact a where -- | Function for obtaining the name of a fact -- (has to be the same as described in the Datalog program). - -- - -- It uses a 'Proxy' to select the correct instance. - factName :: Proxy a -> String + factName :: String -- | A helper data type, used in combination with the DerivingVia extension to -- automatically generate code to bind a Haskell datatype to a Souffle @@ -186,26 +196,30 @@ class Marshal.Marshal a => Fact a where -- deriving (Eq, Show, Generic) -- deriving anyclass Souffle.Marshal -- deriving Souffle.Fact --- via Souffle.FactOptions Edge "edge" 'Souffle.Input +-- via Souffle.FactOptions Edge "edge" Souffle.Input -- @ -- -- See also: 'ProgramOptions'. type FactOptions :: Type -> Symbol -> Direction -> Type -newtype FactOptions fact factName dir - = FactOptions fact +newtype FactOptions fact factName dir = FactOptions fact +type role FactOptions representational phantom phantom instance Marshal.Marshal fact => Marshal.Marshal (FactOptions fact name dir) where + push :: (Marshal.Marshal fact, Marshal.MonadPush m) => FactOptions fact name dir -> m Unit push (FactOptions fact) = Marshal.push fact {-# INLINABLE push #-} + + pop :: (Marshal.Marshal fact, Marshal.MonadPop m) => m (FactOptions fact name dir) pop = FactOptions <$> Marshal.pop {-# INLINABLE pop #-} instance ( Marshal.Marshal fact - , KnownSymbol factName - ) => Fact (FactOptions fact factName dir) where + , KnownSymbol name + ) => Fact (FactOptions fact name dir) where type FactDirection (FactOptions _ _ dir) = dir - factName = const $ symbolVal (Proxy @factName) + factName :: (Marshal.Marshal fact, KnownSymbol name) => String + factName = show $ symbolSing @name {-# INLINABLE factName #-} @@ -241,10 +255,10 @@ class Monad m => MonadSouffle m where type SubmitFacts m (a :: Type) :: Constraint -- | Runs the Souffle program. - run :: Handler m prog -> m () + run :: Handler m prog -> m Unit -- | Sets the number of CPU cores this Souffle program should use. - setNumThreads :: Handler m prog -> Word64 -> m () + setNumThreads :: Handler m prog -> Word64 -> m Unit -- | Gets the number of CPU cores this Souffle program should use. getNumThreads :: Handler m prog -> m Word64 @@ -263,151 +277,280 @@ class Monad m => MonadSouffle m where => Handler m prog -> a -> m (Maybe a) -- | Adds a fact to the program. - addFact :: (Fact a, ContainsInputFact prog a, SubmitFacts m a) - => Handler m prog -> a -> m () + addFact :: (Fact a, ContainsInputFact prog a, SubmitFacts m a, Show a) + => Handler m prog -> a -> m Unit -- | Adds multiple facts to the program. This function could be implemented -- in terms of 'addFact', but this is done as a minor optimization. addFacts :: (Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts m a) - => Handler m prog -> t a -> m () + => Handler m prog -> t a -> m Unit instance MonadSouffle m => MonadSouffle (ReaderT r m) where - type Handler (ReaderT r m) = Handler m + type Handler (ReaderT r m) = Handler m type CollectFacts (ReaderT r m) c = CollectFacts m c - type SubmitFacts (ReaderT r m) a = SubmitFacts m a + type SubmitFacts (ReaderT r m) a = SubmitFacts m a + run :: MonadSouffle m => Handler (ReaderT r m) prog -> ReaderT r m Unit run = lift . run {-# INLINABLE run #-} + + setNumThreads :: MonadSouffle m => Handler (ReaderT r m) prog -> Word64 -> ReaderT r m Unit setNumThreads prog = lift . setNumThreads prog {-# INLINABLE setNumThreads #-} + + getNumThreads :: MonadSouffle m => Handler (ReaderT r m) prog -> ReaderT r m Word64 getNumThreads = lift . getNumThreads {-# INLINABLE getNumThreads #-} + + getFacts :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, CollectFacts (ReaderT r m) c) + => Handler (ReaderT r m) prog -> ReaderT r m (c a) getFacts = lift . getFacts {-# INLINABLE getFacts #-} + + findFact :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, Eq a, SubmitFacts (ReaderT r m) a) + => Handler (ReaderT r m) prog -> a -> ReaderT r m (Maybe a) findFact prog = lift . findFact prog {-# INLINABLE findFact #-} + + addFact :: (MonadSouffle m, Fact a, ContainsInputFact prog a, SubmitFacts (ReaderT r m) a, Show a) + => Handler (ReaderT r m) prog -> a -> ReaderT r m Unit addFact fact = lift . addFact fact {-# INLINABLE addFact #-} + + addFacts :: (MonadSouffle m, Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts (ReaderT r m) a) + => Handler (ReaderT r m) prog -> t a -> ReaderT r m Unit addFacts facts = lift . addFacts facts {-# INLINABLE addFacts #-} instance (Monoid w, MonadSouffle m) => MonadSouffle (WriterT w m) where - type Handler (WriterT w m) = Handler m + type Handler (WriterT w m) = Handler m type CollectFacts (WriterT w m) c = CollectFacts m c - type SubmitFacts (WriterT w m) a = SubmitFacts m a + type SubmitFacts (WriterT w m) a = SubmitFacts m a + run :: (Monoid w, MonadSouffle m) => Handler (WriterT w m) prog -> WriterT w m Unit run = lift . run {-# INLINABLE run #-} + + setNumThreads :: (Monoid w, MonadSouffle m) => Handler (WriterT w m) prog -> Word64 -> WriterT w m Unit setNumThreads prog = lift . setNumThreads prog {-# INLINABLE setNumThreads #-} + + getNumThreads :: (Monoid w, MonadSouffle m) => Handler (WriterT w m) prog -> WriterT w m Word64 getNumThreads = lift . getNumThreads {-# INLINABLE getNumThreads #-} + + getFacts :: (Monoid w, MonadSouffle m, Fact a, ContainsOutputFact prog a, CollectFacts (WriterT w m) c) + => Handler (WriterT w m) prog -> WriterT w m (c a) getFacts = lift . getFacts {-# INLINABLE getFacts #-} + + findFact :: (Monoid w, MonadSouffle m, Fact a, ContainsOutputFact prog a, Eq a, SubmitFacts (WriterT w m) a) + => Handler (WriterT w m) prog -> a -> WriterT w m (Maybe a) findFact prog = lift . findFact prog {-# INLINABLE findFact #-} + + addFact :: (Monoid w, MonadSouffle m, Fact a, ContainsInputFact prog a, SubmitFacts (WriterT w m) a, Show a) + => Handler (WriterT w m) prog -> a -> WriterT w m Unit addFact fact = lift . addFact fact {-# INLINABLE addFact #-} + + addFacts :: (Monoid w, MonadSouffle m, Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts (WriterT w m) a) + => Handler (WriterT w m) prog -> t a -> WriterT w m Unit addFacts facts = lift . addFacts facts {-# INLINABLE addFacts #-} instance MonadSouffle m => MonadSouffle (LazyState.StateT s m) where - type Handler (LazyState.StateT s m) = Handler m + type Handler (LazyState.StateT s m) = Handler m type CollectFacts (LazyState.StateT s m) c = CollectFacts m c - type SubmitFacts (LazyState.StateT s m) a = SubmitFacts m a + type SubmitFacts (LazyState.StateT s m) a = SubmitFacts m a + run :: MonadSouffle m => Handler (LazyState.StateT s m) prog -> LazyState.StateT s m Unit run = lift . run {-# INLINABLE run #-} + + setNumThreads :: MonadSouffle m => + Handler (LazyState.StateT s m) prog -> Word64 -> LazyState.StateT s m Unit setNumThreads prog = lift . setNumThreads prog {-# INLINABLE setNumThreads #-} + + getNumThreads :: MonadSouffle m => + Handler (LazyState.StateT s m) prog -> LazyState.StateT s m Word64 getNumThreads = lift . getNumThreads {-# INLINABLE getNumThreads #-} + + getFacts :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, CollectFacts (LazyState.StateT s m) c) => + Handler (LazyState.StateT s m) prog -> LazyState.StateT s m (c a) getFacts = lift . getFacts {-# INLINABLE getFacts #-} + + findFact :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, Eq a, SubmitFacts (LazyState.StateT s m) a) => + Handler (LazyState.StateT s m) prog -> a -> LazyState.StateT s m (Maybe a) findFact prog = lift . findFact prog {-# INLINABLE findFact #-} + + addFact :: (MonadSouffle m, Fact a, ContainsInputFact prog a, SubmitFacts (LazyState.StateT s m) a, Show a) => + Handler (LazyState.StateT s m) prog -> a -> LazyState.StateT s m Unit addFact fact = lift . addFact fact {-# INLINABLE addFact #-} + + addFacts :: (MonadSouffle m, Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts (LazyState.StateT s m) a) => + Handler (LazyState.StateT s m) prog -> t a -> LazyState.StateT s m Unit addFacts facts = lift . addFacts facts {-# INLINABLE addFacts #-} instance MonadSouffle m => MonadSouffle (StrictState.StateT s m) where - type Handler (StrictState.StateT s m) = Handler m + type Handler (StrictState.StateT s m) = Handler m type CollectFacts (StrictState.StateT s m) c = CollectFacts m c - type SubmitFacts (StrictState.StateT s m) a = SubmitFacts m a + type SubmitFacts (StrictState.StateT s m) a = SubmitFacts m a + run :: MonadSouffle m => Handler (StrictState.StateT s m) prog -> StrictState.StateT s m Unit run = lift . run {-# INLINABLE run #-} + + setNumThreads :: MonadSouffle m => + Handler (StrictState.StateT s m) prog -> Word64 -> StrictState.StateT s m Unit setNumThreads prog = lift . setNumThreads prog {-# INLINABLE setNumThreads #-} + + getNumThreads :: MonadSouffle m => + Handler (StrictState.StateT s m) prog -> StrictState.StateT s m Word64 getNumThreads = lift . getNumThreads {-# INLINABLE getNumThreads #-} + + getFacts :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, CollectFacts (StrictState.StateT s m) c) => + Handler (StrictState.StateT s m) prog -> StrictState.StateT s m (c a) getFacts = lift . getFacts {-# INLINABLE getFacts #-} + + findFact :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, Eq a, SubmitFacts (StrictState.StateT s m) a) => + Handler (StrictState.StateT s m) prog -> a -> StrictState.StateT s m (Maybe a) findFact prog = lift . findFact prog {-# INLINABLE findFact #-} + + addFact :: (MonadSouffle m, Fact a, ContainsInputFact prog a, SubmitFacts (StrictState.StateT s m) a, Show a) => + Handler (StrictState.StateT s m) prog -> a -> StrictState.StateT s m Unit addFact fact = lift . addFact fact {-# INLINABLE addFact #-} + + addFacts :: (MonadSouffle m, Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts (StrictState.StateT s m) a) => + Handler (StrictState.StateT s m) prog -> t a -> StrictState.StateT s m Unit addFacts facts = lift . addFacts facts {-# INLINABLE addFacts #-} instance (MonadSouffle m, Monoid w) => MonadSouffle (LazyRWS.RWST r w s m) where - type Handler (LazyRWS.RWST r w s m) = Handler m + type Handler (LazyRWS.RWST r w s m) = Handler m type CollectFacts (LazyRWS.RWST r w s m) c = CollectFacts m c - type SubmitFacts (LazyRWS.RWST r w s m) a = SubmitFacts m a + type SubmitFacts (LazyRWS.RWST r w s m) a = SubmitFacts m a + run :: (MonadSouffle m, Monoid w) => + Handler (LazyRWS.RWST r w s m) prog -> LazyRWS.RWST r w s m Unit run = lift . run {-# INLINABLE run #-} + + setNumThreads :: (MonadSouffle m, Monoid w) => + Handler (LazyRWS.RWST r w s m) prog -> Word64 -> LazyRWS.RWST r w s m Unit setNumThreads prog = lift . setNumThreads prog {-# INLINABLE setNumThreads #-} + + getNumThreads :: (MonadSouffle m, Monoid w) => + Handler (LazyRWS.RWST r w s m) prog -> LazyRWS.RWST r w s m Word64 getNumThreads = lift . getNumThreads {-# INLINABLE getNumThreads #-} + + getFacts :: (MonadSouffle m, Monoid w, Fact a, ContainsOutputFact prog a, CollectFacts (LazyRWS.RWST r w s m) c) => + Handler (LazyRWS.RWST r w s m) prog -> LazyRWS.RWST r w s m (c a) getFacts = lift . getFacts {-# INLINABLE getFacts #-} + + findFact :: (MonadSouffle m, Monoid w, Fact a, ContainsOutputFact prog a, Eq a, SubmitFacts (LazyRWS.RWST r w s m) a) => + Handler (LazyRWS.RWST r w s m) prog -> a -> LazyRWS.RWST r w s m (Maybe a) findFact prog = lift . findFact prog {-# INLINABLE findFact #-} + + addFact :: (MonadSouffle m, Monoid w, Fact a, ContainsInputFact prog a, SubmitFacts (LazyRWS.RWST r w s m) a, Show a) => + Handler (LazyRWS.RWST r w s m) prog -> a -> LazyRWS.RWST r w s m Unit addFact fact = lift . addFact fact {-# INLINABLE addFact #-} + + addFacts :: (MonadSouffle m, Monoid w, Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts (LazyRWS.RWST r w s m) a) => + Handler (LazyRWS.RWST r w s m) prog -> t a -> LazyRWS.RWST r w s m Unit addFacts facts = lift . addFacts facts {-# INLINABLE addFacts #-} instance (MonadSouffle m, Monoid w) => MonadSouffle (StrictRWS.RWST r w s m) where - type Handler (StrictRWS.RWST r w s m) = Handler m + type Handler (StrictRWS.RWST r w s m) = Handler m type CollectFacts (StrictRWS.RWST r w s m) c = CollectFacts m c - type SubmitFacts (StrictRWS.RWST r w s m) a = SubmitFacts m a + type SubmitFacts (StrictRWS.RWST r w s m) a = SubmitFacts m a + run :: (MonadSouffle m, Monoid w) => Handler (StrictRWS.RWST r w s m) prog -> StrictRWS.RWST r w s m Unit run = lift . run {-# INLINABLE run #-} + + setNumThreads :: (MonadSouffle m, Monoid w) => + Handler (StrictRWS.RWST r w s m) prog -> Word64 -> StrictRWS.RWST r w s m Unit setNumThreads prog = lift . setNumThreads prog {-# INLINABLE setNumThreads #-} + + getNumThreads :: (MonadSouffle m, Monoid w) => + Handler (StrictRWS.RWST r w s m) prog -> StrictRWS.RWST r w s m Word64 getNumThreads = lift . getNumThreads {-# INLINABLE getNumThreads #-} + + getFacts :: (MonadSouffle m, Monoid w, Fact a, ContainsOutputFact prog a, CollectFacts (StrictRWS.RWST r w s m) c) => + Handler (StrictRWS.RWST r w s m) prog -> StrictRWS.RWST r w s m (c a) getFacts = lift . getFacts {-# INLINABLE getFacts #-} + + findFact :: (MonadSouffle m, Monoid w, Fact a, ContainsOutputFact prog a, Eq a, SubmitFacts (StrictRWS.RWST r w s m) a) => + Handler (StrictRWS.RWST r w s m) prog -> a -> StrictRWS.RWST r w s m (Maybe a) findFact prog = lift . findFact prog {-# INLINABLE findFact #-} + + addFact :: (MonadSouffle m, Monoid w, Fact a, ContainsInputFact prog a, SubmitFacts (StrictRWS.RWST r w s m) a, Show a) => + Handler (StrictRWS.RWST r w s m) prog -> a -> StrictRWS.RWST r w s m Unit addFact fact = lift . addFact fact {-# INLINABLE addFact #-} + + addFacts :: (MonadSouffle m, Monoid w, Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts (StrictRWS.RWST r w s m) a) => + Handler (StrictRWS.RWST r w s m) prog -> t a -> StrictRWS.RWST r w s m Unit addFacts facts = lift . addFacts facts {-# INLINABLE addFacts #-} instance MonadSouffle m => MonadSouffle (ExceptT e m) where - type Handler (ExceptT e m) = Handler m + type Handler (ExceptT e m) = Handler m type CollectFacts (ExceptT e m) c = CollectFacts m c - type SubmitFacts (ExceptT e m) a = SubmitFacts m a + type SubmitFacts (ExceptT e m) a = SubmitFacts m a + run :: MonadSouffle m => Handler (ExceptT e m) prog -> ExceptT e m Unit run = lift . run {-# INLINABLE run #-} + + setNumThreads :: MonadSouffle m => + Handler (ExceptT e m) prog -> Word64 -> ExceptT e m Unit setNumThreads prog = lift . setNumThreads prog {-# INLINABLE setNumThreads #-} + + getNumThreads :: MonadSouffle m => Handler (ExceptT e m) prog -> ExceptT e m Word64 getNumThreads = lift . getNumThreads {-# INLINABLE getNumThreads #-} + + getFacts :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, CollectFacts (ExceptT e m) c) => + Handler (ExceptT e m) prog -> ExceptT e m (c a) getFacts = lift . getFacts {-# INLINABLE getFacts #-} + + findFact :: (MonadSouffle m, Fact a, ContainsOutputFact prog a, Eq a,SubmitFacts (ExceptT e m) a) => + Handler (ExceptT e m) prog -> a -> ExceptT e m (Maybe a) findFact prog = lift . findFact prog {-# INLINABLE findFact #-} + + addFact :: (MonadSouffle m, Fact a, ContainsInputFact prog a, SubmitFacts (ExceptT e m) a, Show a) => + Handler (ExceptT e m) prog -> a -> ExceptT e m Unit addFact fact = lift . addFact fact {-# INLINABLE addFact #-} + + addFacts :: (MonadSouffle m, Foldable t, Fact a, ContainsInputFact prog a, SubmitFacts (ExceptT e m) a) => + Handler (ExceptT e m) prog -> t a -> ExceptT e m Unit addFacts facts = lift . addFacts facts {-# INLINABLE addFacts #-} @@ -415,51 +558,84 @@ instance MonadSouffle m => MonadSouffle (ExceptT e m) where type MonadSouffleFileIO :: (Type -> Type) -> Constraint class MonadSouffle m => MonadSouffleFileIO m where -- | Load all facts from files in a certain directory. - loadFiles :: Handler m prog -> FilePath -> m () + loadFiles :: Handler m prog -> FilePath -> m Unit -- | Write out all facts of the program to CSV files in a certain directory -- (as defined in the Souffle program). - writeFiles :: Handler m prog -> FilePath -> m () + writeFiles :: Handler m prog -> FilePath -> m Unit instance MonadSouffleFileIO m => MonadSouffleFileIO (ReaderT r m) where + loadFiles :: MonadSouffleFileIO m => + Handler (ReaderT r m) prog -> FilePath -> ReaderT r m Unit loadFiles prog = lift . loadFiles prog {-# INLINABLE loadFiles #-} + + writeFiles :: MonadSouffleFileIO m => + Handler (ReaderT r m) prog -> FilePath -> ReaderT r m Unit writeFiles prog = lift . writeFiles prog {-# INLINABLE writeFiles #-} instance (Monoid w, MonadSouffleFileIO m) => MonadSouffleFileIO (WriterT w m) where + loadFiles :: (Monoid w, MonadSouffleFileIO m) => + Handler (WriterT w m) prog -> FilePath -> WriterT w m Unit loadFiles prog = lift . loadFiles prog {-# INLINABLE loadFiles #-} + + writeFiles :: (Monoid w, MonadSouffleFileIO m) => + Handler (WriterT w m) prog -> FilePath -> WriterT w m Unit writeFiles prog = lift . writeFiles prog {-# INLINABLE writeFiles #-} instance MonadSouffleFileIO m => MonadSouffleFileIO (StrictState.StateT s m) where + loadFiles :: MonadSouffleFileIO m => + Handler (StrictState.StateT s m) prog -> FilePath -> StrictState.StateT s m Unit loadFiles prog = lift . loadFiles prog {-# INLINABLE loadFiles #-} + + writeFiles :: MonadSouffleFileIO m => + Handler (StrictState.StateT s m) prog -> FilePath -> StrictState.StateT s m Unit writeFiles prog = lift . writeFiles prog {-# INLINABLE writeFiles #-} instance MonadSouffleFileIO m => MonadSouffleFileIO (LazyState.StateT s m) where + loadFiles :: MonadSouffleFileIO m => + Handler (LazyState.StateT s m) prog -> FilePath -> LazyState.StateT s m Unit loadFiles prog = lift . loadFiles prog {-# INLINABLE loadFiles #-} + + writeFiles :: MonadSouffleFileIO m => + Handler (LazyState.StateT s m) prog -> FilePath -> LazyState.StateT s m Unit writeFiles prog = lift . writeFiles prog {-# INLINABLE writeFiles #-} instance (MonadSouffleFileIO m, Monoid w) => MonadSouffleFileIO (LazyRWS.RWST r w s m) where + loadFiles :: (MonadSouffleFileIO m, Monoid w) => + Handler (LazyRWS.RWST r w s m) prog -> FilePath -> LazyRWS.RWST r w s m Unit loadFiles prog = lift . loadFiles prog {-# INLINABLE loadFiles #-} + + writeFiles :: (MonadSouffleFileIO m, Monoid w) + => Handler (LazyRWS.RWST r w s m) prog -> FilePath -> LazyRWS.RWST r w s m Unit writeFiles prog = lift . writeFiles prog {-# INLINABLE writeFiles #-} instance (MonadSouffleFileIO m, Monoid w) => MonadSouffleFileIO (StrictRWS.RWST r w s m) where + loadFiles :: (MonadSouffleFileIO m, Monoid w) => + Handler (StrictRWS.RWST r w s m) prog -> FilePath -> StrictRWS.RWST r w s m Unit loadFiles prog = lift . loadFiles prog {-# INLINABLE loadFiles #-} + + writeFiles :: (MonadSouffleFileIO m, Monoid w) => + Handler (StrictRWS.RWST r w s m) prog -> FilePath -> StrictRWS.RWST r w s m Unit writeFiles prog = lift . writeFiles prog {-# INLINABLE writeFiles #-} instance MonadSouffleFileIO m => MonadSouffleFileIO (ExceptT s m) where + loadFiles :: MonadSouffleFileIO m => Handler (ExceptT s m) prog -> FilePath -> ExceptT s m Unit loadFiles prog = lift . loadFiles prog {-# INLINABLE loadFiles #-} + + writeFiles :: MonadSouffleFileIO m => Handler (ExceptT s m) prog -> FilePath -> ExceptT s m Unit writeFiles prog = lift . writeFiles prog {-# INLINABLE writeFiles #-} diff --git a/lib/Language/Souffle/Compiled.hs b/lib/Language/Souffle/Compiled.hs index 9570101..a65943e 100644 --- a/lib/Language/Souffle/Compiled.hs +++ b/lib/Language/Souffle/Compiled.hs @@ -1,9 +1,3 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies, DerivingVia #-} -{-# LANGUAGE BangPatterns, RoleAnnotations, MultiParamTypeClasses #-} -{-# LANGUAGE InstanceSigs, DataKinds, TypeApplications, TypeOperators #-} -{-# LANGUAGE ConstraintKinds, PolyKinds, UndecidableInstances #-} - -- | This module provides an implementation for the typeclasses defined in -- "Language.Souffle.Class". -- It makes use of the low level Souffle C++ API to offer a much more @@ -30,47 +24,75 @@ module Language.Souffle.Compiled , runSouffle ) where -import Prelude hiding ( init ) -import Control.Monad.State.Strict (StateT, MonadState (..), evalStateT, modify, gets) -import Data.Foldable ( traverse_ ) -import Data.Functor.Identity -import Data.Proxy -import Data.Kind -import qualified Data.Array as A -import qualified Data.Array.IO as A -import qualified Data.Array.Unsafe as A -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BSU -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE +import Control.Applicative (Applicative (..)) +import Control.Concurrent (MVar, modifyMVarMasked, modifyMVarMasked_, newMVar) +import Control.Monad (Monad (..), when, (=<<)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.State.Strict (MonadState (..), StateT, evalStateT, gets, modify) + +import qualified Data.Array as A +import qualified Data.Array.IO as A +import qualified Data.Array.Unsafe as A +import Data.Bool (otherwise) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BSU +import Data.Eq (Eq (..)) +import Data.Foldable (Foldable (..), traverse_) +import Data.Function (flip, ($), (.)) +import Data.Functor (Functor, (<$>)) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int, Int32) +import Data.Kind (Constraint, Type) +import Data.List (List) +import Data.Maybe (Maybe (..)) +import Data.Monoid (Monoid, (<>)) +import Data.Ord (Ord (..)) +import Data.Semigroup (Semigroup) +import Data.String (String) +import Data.Text (Text) +import qualified Data.Text as T +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 -import Data.Int -import Data.Word -import Foreign.ForeignPtr -import Foreign.ForeignPtr.Unsafe -import Foreign (copyBytes) -import Foreign.Ptr -import qualified Foreign.Storable as S -import GHC.Generics -import Language.Souffle.Class -import qualified Language.Souffle.Internal as Internal -import Language.Souffle.Marshal -import Control.Concurrent -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import Data.Word (Word32, Word64) + +import Foreign (copyBytes) +import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, newForeignPtr_, withForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr) +import qualified Foreign.Storable as S + +import GHC.Err (error) +import GHC.Float (Float) +import GHC.Generics (Generic (..), K1, M1, type (:*:)) +import GHC.Num (Num (..)) +import GHC.Real (fromIntegral) +import GHC.Tuple (Unit) + +import Language.Souffle.Class (ContainsInputFact, ContainsOutputFact, Direction (..), Fact (..), + FactOptions (..), Marshal (..), MonadSouffle (..), + MonadSouffleFileIO (..), Program (..), ProgramOptions (..)) +import qualified Language.Souffle.Internal as Internal +import Language.Souffle.Marshal (MonadPop (..), MonadPush (..)) + +import Prelude (($!)) + +import System.IO (FilePath, IO) + +import Text.Show (Show) type ByteCount :: Type type ByteCount = Int + type ByteBuf :: Type type ByteBuf = Internal.ByteBuf type BufData :: Type data BufData = BufData - { bufPtr :: {-# UNPACK #-} !(ForeignPtr ByteBuf) + { bufPtr :: {-# UNPACK #-} !(ForeignPtr ByteBuf) , bufSize :: {-# UNPACK #-} !ByteCount } @@ -88,6 +110,7 @@ type SouffleM :: Type -> Type newtype SouffleM a = SouffleM (IO a) deriving (Functor, Applicative, Monad, MonadIO) via IO deriving (Semigroup, Monoid) via (IO a) +type role SouffleM nominal {- | Initializes and runs a Souffle program. @@ -99,7 +122,7 @@ newtype SouffleM a = SouffleM (IO a) -} runSouffle :: forall prog a. Program prog => prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a -runSouffle prog action = +runSouffle !prog !action = let progName = programName prog (SouffleM result) = do maybeHandle <- liftIO (Internal.init progName) >>= \case @@ -122,6 +145,7 @@ type CMarshalFast :: Type -> Type newtype CMarshalFast a = CMarshalFast (StateT (Ptr ByteBuf) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadState (Ptr ByteBuf)) via (StateT (Ptr ByteBuf) IO) +type role CMarshalFast nominal runMarshalFastM :: CMarshalFast a -> Ptr ByteBuf -> IO a runMarshalFastM (CMarshalFast m) = evalStateT m @@ -131,7 +155,7 @@ runMarshalFastM (CMarshalFast m) = evalStateT m ramDomainSize :: Int ramDomainSize = 4 -writeAsBytes :: (S.Storable a, Marshal a) => a -> CMarshalFast () +writeAsBytes :: (S.Storable a, Marshal a) => a -> CMarshalFast Unit writeAsBytes a = do ptr <- gets castPtr liftIO $ S.poke ptr a @@ -147,27 +171,45 @@ readAsBytes = do {-# INLINABLE readAsBytes #-} instance MonadPush CMarshalFast where + pushInt32 :: Int32 -> CMarshalFast Unit pushInt32 = writeAsBytes {-# INLINABLE pushInt32 #-} + + pushUInt32 :: Word32 -> CMarshalFast Unit pushUInt32 = writeAsBytes {-# INLINABLE pushUInt32 #-} + + pushFloat :: Float -> CMarshalFast Unit pushFloat = writeAsBytes {-# INLINABLE pushFloat #-} + + pushString :: String -> CMarshalFast Unit pushString str = pushText $ T.pack str {-# INLINABLE pushString #-} + + pushText :: T.Text -> CMarshalFast Unit pushText _ = error "Fast marshalling does not support serializing string-like values." {-# INLINABLE pushText #-} instance MonadPop CMarshalFast where + popInt32 :: CMarshalFast Int32 popInt32 = readAsBytes {-# INLINABLE popInt32 #-} + + popUInt32 :: CMarshalFast Word32 popUInt32 = readAsBytes {-# INLINABLE popUInt32 #-} + + popFloat :: CMarshalFast Float popFloat = readAsBytes {-# INLINABLE popFloat #-} + + popString :: CMarshalFast String popString = T.unpack <$> popText {-# INLINABLE popString #-} + + popText :: CMarshalFast T.Text popText = do byteCount <- popUInt32 if byteCount == 0 @@ -185,8 +227,8 @@ instance MonadPop CMarshalFast where type MarshalState :: Type data MarshalState = MarshalState - { _buf :: {-# UNPACK #-} !BufData - , _ptr :: {-# UNPACK #-} !(Ptr ByteBuf) + { _buf :: {-# UNPACK #-} !BufData + , _ptr :: {-# UNPACK #-} !(Ptr ByteBuf) , _ptrOffset :: {-# UNPACK #-} !Int } @@ -197,6 +239,7 @@ type CMarshalSlow :: Type -> Type newtype CMarshalSlow a = CMarshalSlow (StateT MarshalState IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadState MarshalState) via (StateT MarshalState IO) +type role CMarshalSlow nominal runMarshalSlowM :: BufData -> Int -> CMarshalSlow a -> IO a runMarshalSlowM bufData byteCount (CMarshalSlow m) = do @@ -207,7 +250,7 @@ runMarshalSlowM bufData byteCount (CMarshalSlow m) = do evalStateT m $ MarshalState bufData' ptr 0 {-# INLINABLE runMarshalSlowM #-} -resizeBufWhenNeeded :: ByteCount -> CMarshalSlow () +resizeBufWhenNeeded :: ByteCount -> CMarshalSlow Unit resizeBufWhenNeeded byteCount = do MarshalState bufData _ offset <- get let totalByteCount = bufSize bufData @@ -225,7 +268,7 @@ allocateBuf byteCount = liftIO $ mallocForeignPtrBytes byteCount {-# INLINABLE allocateBuf #-} -copyBuf :: ForeignPtr ByteBuf -> ForeignPtr ByteBuf -> Int -> CMarshalSlow () +copyBuf :: ForeignPtr ByteBuf -> ForeignPtr ByteBuf -> Int -> CMarshalSlow Unit copyBuf dst src byteCount = liftIO $ withForeignPtr src $ \srcPtr -> withForeignPtr dst $ \dstPtr -> @@ -239,21 +282,30 @@ getNewTotalByteCount byteCount offset = go where | otherwise = totalByteCount {-# INLINABLE getNewTotalByteCount #-} -incrementPtr :: ByteCount -> CMarshalSlow () +incrementPtr :: ByteCount -> CMarshalSlow Unit incrementPtr byteCount = modify $ \(MarshalState buf ptr offset) -> MarshalState buf (ptr `plusPtr` byteCount) (offset + byteCount) {-# INLINABLE incrementPtr #-} instance MonadPush CMarshalSlow where + pushInt32 :: Int32 -> CMarshalSlow Unit pushInt32 = writeAsBytesSlow {-# INLINABLE pushInt32 #-} + + pushUInt32 :: Word32 -> CMarshalSlow Unit pushUInt32 = writeAsBytesSlow {-# INLINABLE pushUInt32 #-} + + pushFloat :: Float -> CMarshalSlow Unit pushFloat = writeAsBytesSlow {-# INLINABLE pushFloat #-} + + pushString :: String -> CMarshalSlow Unit pushString str = pushText $ T.pack str {-# INLINABLE pushString #-} + + pushText :: Text -> CMarshalSlow Unit pushText txt = do let bs = TE.encodeUtf8 txt -- TODO: is it possible to get rid of this copy? len = BS.length bs @@ -267,7 +319,7 @@ instance MonadPush CMarshalSlow where incrementPtr len {-# INLINABLE pushText #-} -writeAsBytesSlow :: (S.Storable a, Marshal a) => a -> CMarshalSlow () +writeAsBytesSlow :: (S.Storable a, Marshal a) => a -> CMarshalSlow Unit writeAsBytesSlow a = do resizeBufWhenNeeded ramDomainSize ptr <- gets (castPtr . _ptr) @@ -280,7 +332,8 @@ type Collect :: (Type -> Type) -> Constraint class Collect c where collect :: Marshal a => Word32 -> CMarshalFast (c a) -instance Collect [] where +instance Collect List where + collect :: Marshal a => Word32 -> CMarshalFast (List a) collect objCount = go objCount [] where go count acc | count == 0 = pure acc @@ -290,6 +343,7 @@ instance Collect [] where {-# INLINABLE collect #-} instance Collect V.Vector where + collect :: Marshal a => Word32 -> CMarshalFast (V.Vector a) collect objCount = do vm <- liftIO $ MV.unsafeNew objCount' collect' vm 0 @@ -304,6 +358,7 @@ instance Collect V.Vector where {-# INLINABLE collect #-} instance Collect (A.Array Int) where + collect :: Marshal a => Word32 -> CMarshalFast (A.Array Int a) collect objCount = do ma <- liftIO $ A.newArray_ (0, objCount' - 1) collect' ma 0 @@ -324,33 +379,36 @@ type Submit :: Type -> Constraint type Submit a = ToByteSize (GetFields (Rep a)) instance MonadSouffle SouffleM where - type Handler SouffleM = Handle + type Handler SouffleM = Handle type CollectFacts SouffleM c = Collect c - type SubmitFacts SouffleM a = Submit a + type SubmitFacts SouffleM a = Submit a + run :: Handler SouffleM prog -> SouffleM Unit run (Handle prog _) = SouffleM $ Internal.run prog {-# INLINABLE run #-} + setNumThreads :: Handler SouffleM prog -> Word64 -> SouffleM Unit setNumThreads (Handle prog _) numCores = SouffleM $ Internal.setNumThreads prog numCores {-# INLINABLE setNumThreads #-} + getNumThreads :: Handler SouffleM prog -> SouffleM Word64 getNumThreads (Handle prog _) = SouffleM $ Internal.getNumThreads prog {-# INLINABLE getNumThreads #-} - addFact :: forall a prog. (Fact a, ContainsInputFact prog a, Submit a) - => Handle prog -> a -> SouffleM () - addFact (Handle prog bufVar) fact = liftIO $ do - let relationName = factName (Proxy :: Proxy a) + addFact :: forall a prog. (Fact a, ContainsInputFact prog a, SubmitFacts SouffleM a, Show a) + => Handle prog -> a -> SouffleM Unit + addFact (Handle !prog !bufVar) !fact = liftIO $ do + let relationName = factName @a relation <- Internal.getRelation prog relationName writeBytes bufVar relation (Identity fact) {-# INLINABLE addFact #-} addFacts :: forall t a prog. (Foldable t, Fact a, ContainsInputFact prog a, Submit a) - => Handle prog -> t a -> SouffleM () + => Handle prog -> t a -> SouffleM Unit addFacts (Handle prog bufVar) facts = liftIO $ do - let relationName = factName (Proxy :: Proxy a) + let relationName = factName @a relation <- Internal.getRelation prog relationName writeBytes bufVar relation facts {-# INLINABLE addFacts #-} @@ -358,7 +416,7 @@ instance MonadSouffle SouffleM where getFacts :: forall a c prog. (Fact a, ContainsOutputFact prog a, Collect c) => Handle prog -> SouffleM (c a) getFacts (Handle prog _) = SouffleM $ do - let relationName = factName (Proxy :: Proxy a) + let relationName = factName @a relation <- Internal.getRelation prog relationName buf <- withForeignPtr prog $ flip Internal.popFacts relation flip runMarshalFastM buf $ collect =<< popUInt32 @@ -367,9 +425,9 @@ instance MonadSouffle SouffleM where findFact :: forall a prog. (Fact a, ContainsOutputFact prog a, Submit a) => Handle prog -> a -> SouffleM (Maybe a) findFact (Handle prog bufVar) fact = SouffleM $ do - let relationName = factName (Proxy :: Proxy a) + let relationName = factName @a relation <- Internal.getRelation prog relationName - found <- case estimateNumBytes (Proxy @a) of + found <- case estimateNumBytes @a of Exact numBytes -> do modifyMVarMasked bufVar $ \bufData -> do bufData' <- if bufSize bufData > numBytes @@ -390,9 +448,11 @@ instance MonadSouffle SouffleM where {-# INLINABLE findFact #-} instance MonadSouffleFileIO SouffleM where + loadFiles :: Handler SouffleM prog -> FilePath -> SouffleM Unit loadFiles (Handle prog _) = SouffleM . Internal.loadAll prog {-# INLINABLE loadFiles #-} + writeFiles :: Handler SouffleM prog -> FilePath -> SouffleM Unit writeFiles (Handle prog _) = SouffleM . Internal.printAll prog {-# INLINABLE writeFiles #-} @@ -403,81 +463,89 @@ data ByteSize | Estimated {-# UNPACK #-} !ByteCount instance Semigroup ByteSize where - Exact s1 <> Exact s2 = Exact (s1 + s2) - Exact s1 <> Estimated s2 = Estimated (s1 + s2) - Estimated s1 <> Exact s2 = Estimated (s1 + s2) + (<>) :: ByteSize -> ByteSize -> ByteSize + Exact s1 <> Exact s2 = Exact (s1 + s2) + Exact s1 <> Estimated s2 = Estimated (s1 + s2) + Estimated s1 <> Exact s2 = Estimated (s1 + s2) Estimated s1 <> Estimated s2 = Estimated (s1 + s2) {-# INLINABLE (<>) #-} -type ToByteSize :: k -> Constraint -class ToByteSize a where - toByteSize :: Proxy a -> ByteSize +type ToByteSize :: forall k. k -> Constraint +class ToByteSize @k a where + toByteSize :: ByteSize instance ToByteSize Int32 where - toByteSize = const $ Exact 4 + toByteSize :: ByteSize + toByteSize = Exact 4 {-# INLINABLE toByteSize #-} instance ToByteSize Word32 where - toByteSize = const $ Exact 4 + toByteSize :: ByteSize + toByteSize = Exact 4 {-# INLINABLE toByteSize #-} instance ToByteSize Float where - toByteSize = const $ Exact 4 + toByteSize :: ByteSize + toByteSize = Exact 4 {-# INLINABLE toByteSize #-} instance ToByteSize String where -- 4 for length prefix + 32 for actual string - toByteSize = const $ Estimated 36 + toByteSize :: ByteSize + toByteSize = Estimated 36 {-# INLINABLE toByteSize #-} instance ToByteSize T.Text where -- 4 for length prefix + 32 for actual string - toByteSize = const $ Estimated 36 + toByteSize :: ByteSize + toByteSize = Estimated 36 {-# INLINABLE toByteSize #-} instance ToByteSize TL.Text where -- 4 for length prefix + 32 for actual string - toByteSize = const $ Estimated 36 + toByteSize :: ByteSize + toByteSize = Estimated 36 {-# INLINABLE toByteSize #-} -instance ToByteSize '[] where - toByteSize = const $ Exact 0 +instance ToByteSize [] where + toByteSize :: ByteSize + toByteSize = Exact 0 {-# INLINABLE toByteSize #-} -instance (ToByteSize a, ToByteSize as) => ToByteSize (a ': as) where - toByteSize = - const $ toByteSize (Proxy @a) <> toByteSize (Proxy @as) +instance (ToByteSize a, ToByteSize as) => ToByteSize @(List Type) (a : as) where + toByteSize :: ByteSize + toByteSize = toByteSize @Type @a <> toByteSize @(List Type) @as {-# INLINABLE toByteSize #-} -- | A helper type family, for getting all directly marshallable fields of a type. -type GetFields :: k -> [Type] +type GetFields :: k -> List Type type family GetFields a where - GetFields (K1 _ a) = DoGetFields a + GetFields (K1 _ a) = DoGetFields a GetFields (M1 _ _ a) = GetFields a - GetFields (f :*: g) = GetFields f ++ GetFields g + GetFields (f :*: g) = GetFields f ++ GetFields g -type DoGetFields :: Type -> [Type] +type DoGetFields :: Type -> List Type type family DoGetFields a where - DoGetFields Int32 = '[Int32] - DoGetFields Word32 = '[Word32] - DoGetFields Float = '[Float] - DoGetFields String = '[String] - DoGetFields T.Text = '[T.Text] - DoGetFields TL.Text = '[TL.Text] - DoGetFields a = GetFields (Rep a) - -type (++) :: [Type] -> [Type] -> [Type] + DoGetFields Int32 = [Int32] + DoGetFields Word32 = [Word32] + DoGetFields Float = [Float] + DoGetFields String = [String] + DoGetFields T.Text = [T.Text] + DoGetFields TL.Text = [TL.Text] + DoGetFields a = GetFields (Rep a) + +type (++) :: List Type -> List Type -> List Type type family a ++ b where - '[] ++ b = b - (a ': as) ++ bs = a ': as ++ bs + [] ++ b = b + (a : as) ++ bs = a : as ++ bs -estimateNumBytes :: forall a. Submit a => Proxy a -> ByteSize -estimateNumBytes _ = toByteSize (Proxy @(GetFields (Rep a))) +estimateNumBytes :: forall a. Submit a => ByteSize +estimateNumBytes = toByteSize @(List Type) @(GetFields (Rep a)) {-# INLINABLE estimateNumBytes #-} writeBytes :: forall f a. (Foldable f, Marshal a, Submit a) - => MVar BufData -> Ptr Internal.Relation -> f a -> IO () -writeBytes bufVar relation fa = case estimateNumBytes (Proxy @a) of + => MVar BufData -> Ptr Internal.Relation -> f a -> IO Unit +writeBytes bufVar relation fa = case estimateNumBytes @a of Exact numBytes -> modifyMVarMasked_ bufVar $ \bufData -> do let totalByteCount = numBytes * objCount bufData' <- if bufSize bufData > totalByteCount diff --git a/lib/Language/Souffle/Internal.hs b/lib/Language/Souffle/Internal.hs index 18d6124..14db89e 100644 --- a/lib/Language/Souffle/Internal.hs +++ b/lib/Language/Souffle/Internal.hs @@ -1,4 +1,3 @@ - -- | An internal module, providing a slightly higher level interface than -- "Language.Souffle.Internal.Bindings". -- It uses more commonly found data types instead of the low level C types @@ -23,17 +22,29 @@ module Language.Souffle.Internal , containsFact ) where -import Prelude hiding ( init ) -import Data.Functor ( (<&>) ) -import Data.Word -import Foreign.C.String -import Foreign.C.Types -import Foreign.ForeignPtr -import Foreign.Ptr +import Control.Applicative (Applicative (..), (<$>)) +import Control.Exception (mask_) + +import Data.Bool (Bool (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor ((<&>)) +import Data.Maybe (Maybe (..)) +import Data.String (String) +import Data.Word (Word64) + +import Foreign.C.String (withCString) +import Foreign.C.Types (CBool (..), CSize (..)) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, nullPtr) + +import GHC.Tuple (Unit) + +import Language.Souffle.Internal.Bindings (ByteBuf, Relation, Souffle) import qualified Language.Souffle.Internal.Bindings as Bindings -import Language.Souffle.Internal.Bindings - ( Souffle, Relation, ByteBuf ) -import Control.Exception (mask_) + +import System.IO (FilePath, IO) + {- | Initializes a Souffle program. @@ -54,7 +65,7 @@ init prog = mask_ $ do {-# INLINABLE init #-} -- | Sets the number of CPU cores this Souffle program should use. -setNumThreads :: ForeignPtr Souffle -> Word64 -> IO () +setNumThreads :: ForeignPtr Souffle -> Word64 -> IO Unit setNumThreads prog numThreads = withForeignPtr prog $ \ptr -> Bindings.setNumThreads ptr $ CSize numThreads {-# INLINABLE setNumThreads #-} @@ -67,18 +78,18 @@ getNumThreads prog = withForeignPtr prog $ \ptr -> do {-# INLINABLE getNumThreads #-} -- | Runs the Souffle program. -run :: ForeignPtr Souffle -> IO () +run :: ForeignPtr Souffle -> IO Unit run prog = withForeignPtr prog Bindings.run {-# INLINABLE run #-} -- | Load all facts from files in a certain directory. -loadAll :: ForeignPtr Souffle -> FilePath -> IO () +loadAll :: ForeignPtr Souffle -> FilePath -> IO Unit loadAll prog inputDir = withForeignPtr prog $ withCString inputDir . Bindings.loadAll {-# INLINABLE loadAll #-} -- | Write out all facts of the program to CSV files in a certain directory -- (as defined in the Souffle program). -printAll :: ForeignPtr Souffle -> FilePath -> IO () +printAll :: ForeignPtr Souffle -> FilePath -> IO Unit printAll prog outputDir = withForeignPtr prog $ withCString outputDir . Bindings.printAll {-# INLINABLE printAll #-} @@ -99,7 +110,7 @@ getRelation prog relation = withForeignPtr prog $ \ptr -> Passing in a different count of objects to what is actually inside the byte buffer will crash. -} -pushFacts :: Ptr Relation -> Ptr ByteBuf -> Word64 -> IO () +pushFacts :: Ptr Relation -> Ptr ByteBuf -> Word64 -> IO Unit pushFacts relation buf x = Bindings.pushByteBuf relation buf (CSize x) {-# INLINABLE pushFacts #-} diff --git a/lib/Language/Souffle/Internal/Bindings.hs b/lib/Language/Souffle/Internal/Bindings.hs index e194c1d..608fffd 100644 --- a/lib/Language/Souffle/Internal/Bindings.hs +++ b/lib/Language/Souffle/Internal/Bindings.hs @@ -1,4 +1,3 @@ - -- | This module provides C bindings exposed by the files in the cbits directory. -- This is an internal module, that is prone to have frequent changes, -- use at your own risk. @@ -19,11 +18,15 @@ module Language.Souffle.Internal.Bindings , containsTuple ) where -import Prelude hiding ( init ) -import Data.Kind (Type) -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr +import Data.Kind (Type) + +import Foreign.C.String (CString) +import Foreign.C.Types (CBool (..), CSize (..)) +import Foreign.Ptr (FunPtr, Ptr) + +import GHC.Tuple (Unit) + +import System.IO (IO) -- | A void type, used for tagging a pointer that points to an embedded @@ -58,7 +61,7 @@ foreign import ccall unsafe "souffle_init" init undefined behavior (in C++). -} foreign import ccall unsafe "&souffle_free" free - :: FunPtr (Ptr Souffle -> IO ()) + :: FunPtr (Ptr Souffle -> IO Unit) {-| Sets the number of CPU cores this Souffle program should use. @@ -67,7 +70,7 @@ foreign import ccall unsafe "&souffle_free" free undefined behavior (in C++). -} foreign import ccall unsafe "souffle_set_num_threads" setNumThreads - :: Ptr Souffle -> CSize -> IO () + :: Ptr Souffle -> CSize -> IO Unit {-| Gets the number of CPU cores this Souffle program should use. @@ -83,7 +86,7 @@ foreign import ccall unsafe "souffle_get_num_threads" getNumThreads it to this function. Not doing so results in undefined behavior (in C++). -} foreign import ccall unsafe "souffle_run" run - :: Ptr Souffle -> IO () + :: Ptr Souffle -> IO Unit {-| Load all facts from files in a certain directory. @@ -91,7 +94,7 @@ foreign import ccall unsafe "souffle_run" run it to this function. Not doing so results in undefined behavior (in C++). -} foreign import ccall unsafe "souffle_load_all" loadAll - :: Ptr Souffle -> CString -> IO () + :: Ptr Souffle -> CString -> IO Unit {-| Write out all facts of the program to CSV files in a given directory (as defined in the Souffle program). @@ -100,7 +103,7 @@ foreign import ccall unsafe "souffle_load_all" loadAll to this function. Not doing so results in undefined behavior (in C++). -} foreign import ccall unsafe "souffle_print_all" printAll - :: Ptr Souffle -> CString -> IO () + :: Ptr Souffle -> CString -> IO Unit {-| Lookup a relation in the Souffle program. @@ -123,7 +126,7 @@ foreign import ccall unsafe "souffle_relation" getRelation foreign import ccall unsafe "souffle_contains_tuple" containsTuple :: Ptr Relation -> Ptr ByteBuf -> IO CBool -{-| Serializes many Datalog facts from Haskell to C++. +{-| Serializes many `Datalog` facts from Haskell to C++. You need to check if the passed pointers are non-NULL before passing it to this function. Not doing so results in undefined behavior. @@ -131,7 +134,7 @@ foreign import ccall unsafe "souffle_contains_tuple" containsTuple byte buffer will crash. -} foreign import ccall unsafe "souffle_tuple_push_many" pushByteBuf - :: Ptr Relation -> Ptr ByteBuf -> CSize -> IO () + :: Ptr Relation -> Ptr ByteBuf -> CSize -> IO Unit {-| Serializes many Datalog facts from Datalog to Haskell diff --git a/lib/Language/Souffle/Interpreted.hs b/lib/Language/Souffle/Interpreted.hs index bae427c..f942c06 100644 --- a/lib/Language/Souffle/Interpreted.hs +++ b/lib/Language/Souffle/Interpreted.hs @@ -1,7 +1,3 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# LANGUAGE FlexibleInstances, TypeFamilies, DerivingVia, InstanceSigs #-} -{-# LANGUAGE UndecidableInstances, RoleAnnotations #-} - -- | This module provides an implementation for the `MonadSouffle` typeclass -- defined in "Language.Souffle.Class". -- It makes use of the Souffle interpreter and CSV files to offer an @@ -30,35 +26,58 @@ module Language.Souffle.Interpreted , souffleStdErr ) where -import Prelude hiding (init) -import Data.Kind (Type, Constraint) - -import Control.DeepSeq (deepseq) -import Control.Exception (ErrorCall(..), throwIO, bracket) -import Control.Monad.State.Strict (State, MonadState (state), modify, evalState, execState) -import Data.IORef -import Data.Foldable (traverse_) -import qualified Data.List as List hiding (init) -import Data.Semigroup (Last(..)) -import Data.Maybe (fromMaybe) -import Data.Proxy -import qualified Data.Array as A -import qualified Data.Text as T -import qualified Data.Vector as V -import Data.Word -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.IO (hGetContents, hClose) -import System.IO.Temp -import System.Process -import Text.Printf - -import Language.Souffle.Class -import Language.Souffle.Marshal -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad (forM, (<$!>), forM_) +import Control.Applicative (Applicative (..)) +import Control.DeepSeq (deepseq) +import Control.Exception (ErrorCall (..), bracket, throwIO) +import Control.Monad (Monad (..), forM, forM_, (<$!>)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.State.Strict (MonadState (state), State, evalState, execState, modify) + +import qualified Data.Array as A +import Data.Bool (Bool (False, True)) +import Data.Char (Char) +import Data.Eq (Eq ((==))) +import Data.Foldable (Foldable (..), traverse_) +import Data.Function (($), (.)) +import Data.Functor (Functor (..), (<$>)) +import Data.Int (Int, Int32) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.Kind (Constraint, Type) +import Data.List (List, break, drop, reverse, (++)) +import qualified Data.List as List hiding (init) +import Data.Maybe (Maybe (..), fromMaybe, maybe) +import Data.Monoid (Monoid (..), (<>)) +import Data.Semigroup (Last (..), Semigroup) +import Data.String (String, lines, words) +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Word (Word32, Word64) + +import GHC.Classes (CUnit) +import GHC.Err (error) +import GHC.Float (Float) +import GHC.Num (Num (..)) +import GHC.Tuple (Unit) + +import Language.Souffle.Class (ContainsInputFact, ContainsOutputFact, Direction (..), Fact (..), + FactOptions (..), Marshal (..), MonadSouffle (..), Program (..), + ProgramOptions (..)) +import Language.Souffle.Marshal (MonadPop (..), MonadPush (..)) + +import Prelude (($!)) + +import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (FilePath, (<.>), ()) +import System.IO (IO, appendFile, hClose, hGetContents, readFile) +import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) +import System.Process (CreateProcess (..), StdStream (..), createProcess, createProcess_, shell, + waitForProcess) + +import Text.Printf (printf) +import Text.Read (read) +import Text.Show (Show (..)) -- | A monad for executing Souffle-related actions in. @@ -66,6 +85,7 @@ type SouffleM :: Type -> Type newtype SouffleM a = SouffleM (IO a) deriving (Functor, Applicative, Monad, MonadIO) via IO deriving (Semigroup, Monoid) via (IO a) +type role SouffleM representational -- | A helper data type for storing the configurable settings of the -- interpreter. @@ -82,10 +102,10 @@ newtype SouffleM a = SouffleM (IO a) type Config :: Type data Config = Config - { cfgDatalogDir :: FilePath - , cfgSouffleBin :: Maybe FilePath - , cfgFactDir :: Maybe FilePath - , cfgOutputDir :: Maybe FilePath + { cfgDatalogDir :: FilePath + , cfgSouffleBin :: Maybe FilePath + , cfgFactDir :: Maybe FilePath + , cfgOutputDir :: Maybe FilePath } deriving stock Show -- | Retrieves the default config for the interpreter. These settings can @@ -195,47 +215,58 @@ data HandleData = HandleData } type IMarshal :: Type -> Type -newtype IMarshal a = IMarshal (State [String] a) - deriving (Functor, Applicative, Monad, MonadState [String]) - via (State [String]) +newtype IMarshal a = IMarshal (State (List String) a) + deriving (Functor, Applicative, Monad, MonadState (List String)) + via (State (List String)) +type role IMarshal nominal instance MonadPush IMarshal where + pushInt32 :: Int32 -> IMarshal Unit pushInt32 int = modify (show int:) {-# INLINABLE pushInt32 #-} + pushUInt32 :: Word32 -> IMarshal Unit pushUInt32 int = modify (show int:) {-# INLINABLE pushUInt32 #-} + pushFloat :: Float -> IMarshal Unit pushFloat float = modify (show float:) {-# INLINABLE pushFloat #-} + pushString :: String -> IMarshal Unit pushString str = modify (str:) {-# INLINABLE pushString #-} + pushText :: T.Text -> IMarshal Unit pushText txt = pushString (T.unpack txt) {-# INLINABLE pushText #-} instance MonadPop IMarshal where + popInt32 :: IMarshal Int32 popInt32 = state $ \case [] -> error "Empty fact stack" (h:t) -> (read h, t) {-# INLINABLE popInt32 #-} + popUInt32 :: IMarshal Word32 popUInt32 = state $ \case [] -> error "Empty fact stack" (h:t) -> (read h, t) {-# INLINABLE popUInt32 #-} + popFloat :: IMarshal Float popFloat = state $ \case [] -> error "Empty fact stack" (h:t) -> (read h, t) {-# INLINABLE popFloat #-} + popString :: IMarshal String popString = state $ \case [] -> error "Empty fact stack" (h:t) -> (h, t) {-# INLINABLE popString #-} + popText :: IMarshal T.Text popText = do str <- state $ \case [] -> error "Empty fact stack" @@ -243,11 +274,11 @@ instance MonadPop IMarshal where pure $ T.pack str {-# INLINABLE popText #-} -popMarshalT :: IMarshal a -> [String] -> a +popMarshalT :: IMarshal a -> List String -> a popMarshalT (IMarshal m) = evalState m {-# INLINABLE popMarshalT #-} -pushMarshalT :: IMarshal a -> [String] +pushMarshalT :: IMarshal a -> List String pushMarshalT (IMarshal m) = reverse $ execState m [] {-# INLINABLE pushMarshalT #-} @@ -255,18 +286,21 @@ type Collect :: (Type -> Type) -> Constraint class Collect c where collect :: Marshal a => FilePath -> IO (c a) -instance Collect [] where +instance Collect List where + collect :: Marshal a => FilePath -> IO (List a) collect factFile = do factLines <- readCSVFile factFile - let facts = map (popMarshalT pop) factLines + let facts = fmap (popMarshalT pop) factLines pure $! facts {-# INLINABLE collect #-} instance Collect V.Vector where + collect :: Marshal a => FilePath -> IO (V.Vector a) collect factFile = V.fromList <$!> collect factFile {-# INLINABLE collect #-} instance Collect (A.Array Int) where + collect :: Marshal a => FilePath -> IO (A.Array Int a) collect factFile = do facts <- collect factFile let count = length facts @@ -274,10 +308,11 @@ instance Collect (A.Array Int) where {-# INLINABLE collect #-} instance MonadSouffle SouffleM where - type Handler SouffleM = Handle + type Handler SouffleM = Handle type CollectFacts SouffleM c = Collect c - type SubmitFacts SouffleM _ = () + type SubmitFacts SouffleM _ = CUnit + run :: Handler SouffleM prog -> SouffleM Unit run (Handle refHandleData refHandleStdOut refHandleStdErr) = liftIO $ do handle <- readIORef refHandleData -- Invoke the souffle binary using parameters, supposing that the facts @@ -313,10 +348,12 @@ instance MonadSouffle SouffleM where ) {-# INLINABLE run #-} + setNumThreads :: Handler SouffleM prog -> Word64 -> SouffleM Unit setNumThreads handle n = liftIO $ modifyIORef' (handleData handle) (\h -> h { noOfThreads = n }) {-# INLINABLE setNumThreads #-} + getNumThreads :: Handler SouffleM prog -> SouffleM Word64 getNumThreads handle = liftIO $ noOfThreads <$> readIORef (handleData handle) {-# INLINABLE getNumThreads #-} @@ -325,7 +362,7 @@ instance MonadSouffle SouffleM where => Handle prog -> SouffleM (c a) getFacts h = liftIO $ do handle <- readIORef $ handleData h - let relationName = factName (Proxy :: Proxy a) + let relationName = factName @a let factFile = outputPath handle relationName <.> "csv" facts <- collect factFile pure $! facts -- force facts before running to avoid issues with lazy IO @@ -334,27 +371,27 @@ instance MonadSouffle SouffleM where findFact :: (Fact a, ContainsOutputFact prog a, Eq a) => Handle prog -> a -> SouffleM (Maybe a) findFact prog fact = do - facts :: [a] <- getFacts prog + facts :: List a <- getFacts prog pure $ List.find (== fact) facts {-# INLINABLE findFact #-} addFact :: forall a prog. (Fact a, ContainsInputFact prog a, Marshal a) - => Handle prog -> a -> SouffleM () + => Handle prog -> a -> SouffleM Unit addFact h fact = liftIO $ do handle <- readIORef $ handleData h - let relationName = factName (Proxy :: Proxy a) + let relationName = factName @a let factFile = factPath handle relationName <.> "facts" let line = pushMarshalT (push fact) appendFile factFile $ List.intercalate "\t" line ++ "\n" {-# INLINABLE addFact #-} addFacts :: forall a prog f. (Fact a, ContainsInputFact prog a, Marshal a, Foldable f) - => Handle prog -> f a -> SouffleM () + => Handle prog -> f a -> SouffleM Unit addFacts h facts = liftIO $ do handle <- readIORef $ handleData h - let relationName = factName (Proxy :: Proxy a) + let relationName = factName @a let factFile = factPath handle relationName <.> "facts" - let factLines = map (pushMarshalT . push) (foldMap pure facts) + let factLines = fmap @List (pushMarshalT . push) (foldMap pure facts) traverse_ (\line -> appendFile factFile (List.intercalate "\t" line ++ "\n")) factLines {-# INLINABLE addFacts #-} @@ -376,16 +413,16 @@ locateSouffle = do contents <- hGetContents hout case words contents of [souffleBin] -> pure $ Just souffleBin - _ -> pure Nothing + _ -> pure Nothing {-# INLINABLE locateSouffle #-} -readCSVFile :: FilePath -> IO [[String]] +readCSVFile :: FilePath -> IO (List (List String)) readCSVFile path = doesFileExist path >>= \case False -> pure [] True -> do contents <- readFile path -- deepseq needed to avoid issues with lazy IO - pure $ contents `deepseq` (map (splitOn '\t') . lines) contents + pure $ contents `deepseq` (fmap (splitOn '\t') . lines) contents {-# INLINABLE readCSVFile #-} -- | Returns the handle of stdout from the souffle interpreter. @@ -396,7 +433,7 @@ souffleStdOut = liftIO . readIORef . stdoutResult souffleStdErr :: forall prog. Program prog => Handle prog -> SouffleM (Maybe T.Text) souffleStdErr = liftIO . readIORef . stderrResult -splitOn :: Char -> String -> [String] +splitOn :: Char -> String -> List String splitOn c s = let (x, rest) = break (== c) s rest' = drop 1 rest diff --git a/lib/Language/Souffle/Marshal.hs b/lib/Language/Souffle/Marshal.hs index 6b242d5..5779661 100644 --- a/lib/Language/Souffle/Marshal.hs +++ b/lib/Language/Souffle/Marshal.hs @@ -1,8 +1,3 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE DefaultSignatures, TypeOperators #-} -{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} - -- | This module exposes a uniform interface to marshal values -- to and from Souffle Datalog. This is done via the 'Marshal' typeclass. -- Also, a mechanism is exposed for generically deriving marshalling @@ -14,13 +9,23 @@ module Language.Souffle.Marshal , SimpleProduct ) where -import GHC.TypeLits -import GHC.Generics -import Data.Int -import Data.Word -import Data.Kind -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad) + +import Data.Function ((.)) +import Data.Functor ((<$>)) +import Data.Int (Int32) +import Data.Kind (Constraint, Type) +import Data.String (String) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Word (Word32) + +import GHC.Classes (CTuple2, CUnit) +import GHC.Float (Float) +import GHC.Generics (Generic (..), K1 (..), M1 (..), U1, V1, type (:*:) (..), type (:+:)) +import GHC.Tuple (Unit) +import GHC.TypeLits (ErrorMessage (..), TypeError) {- | A typeclass for serializing primitive values from Haskell to Datalog. @@ -31,15 +36,15 @@ See also: 'MonadPop', 'Marshal'. type MonadPush :: (Type -> Type) -> Constraint class Monad m => MonadPush m where -- | Marshals a signed 32 bit integer to the datalog side. - pushInt32 :: Int32 -> m () + pushInt32 :: Int32 -> m Unit -- | Marshals an unsigned 32 bit integer to the datalog side. - pushUInt32 :: Word32 -> m () + pushUInt32 :: Word32 -> m Unit -- | Marshals a float to the datalog side. - pushFloat :: Float -> m () + pushFloat :: Float -> m Unit -- | Marshals a string to the datalog side. - pushString :: String -> m () + pushString :: String -> m Unit -- | Marshals a UTF8-encoded Text string to the datalog side. - pushText :: T.Text -> m () + pushText :: T.Text -> m Unit {- | A typeclass for serializing primitive values from Datalog to Haskell. @@ -84,79 +89,107 @@ instance Marshal Edge type Marshal :: Type -> Constraint class Marshal a where -- | Marshals a value to the datalog side. - push :: MonadPush m => a -> m () + push :: MonadPush m => a -> m Unit -- | Unmarshals a value from the datalog side. pop :: MonadPop m => m a default push :: (Generic a, SimpleProduct a, GMarshal (Rep a), MonadPush m) - => a -> m () + => a -> m Unit default pop :: (Generic a, SimpleProduct a, GMarshal (Rep a), MonadPop m) => m a push a = gpush (from a) {-# INLINABLE push #-} + pop = to <$> gpop {-# INLINABLE pop #-} instance Marshal Int32 where + push :: MonadPush m => Int32 -> m Unit push = pushInt32 {-# INLINABLE push #-} + + pop :: MonadPop m => m Int32 pop = popInt32 {-# INLINABLE pop #-} instance Marshal Word32 where + push :: MonadPush m => Word32 -> m Unit push = pushUInt32 {-# INLINABLE push #-} + + pop :: MonadPop m => m Word32 pop = popUInt32 {-# INLINABLE pop #-} instance Marshal Float where + push :: MonadPush m => Float -> m Unit push = pushFloat {-# INLINABLE push #-} + + pop :: MonadPop m => m Float pop = popFloat {-# INLINABLE pop #-} instance Marshal String where + push :: MonadPush m => String -> m Unit push = pushString {-# INLINABLE push #-} + + pop :: MonadPop m => m String pop = popString {-# INLINABLE pop #-} instance Marshal T.Text where + push :: MonadPush m => T.Text -> m Unit push = pushText {-# INLINABLE push #-} + + pop :: MonadPop m => m T.Text pop = popText {-# INLINABLE pop #-} instance Marshal TL.Text where + push :: MonadPush m => TL.Text -> m Unit push = push . TL.toStrict {-# INLINABLE push #-} + + pop :: MonadPop m => m TL.Text pop = TL.fromStrict <$> pop {-# INLINABLE pop #-} type GMarshal :: (Type -> Type) -> Constraint class GMarshal f where - gpush :: MonadPush m => f a -> m () + gpush :: MonadPush m => f a -> m Unit gpop :: MonadPop m => m (f a) instance Marshal a => GMarshal (K1 i a) where + gpush :: (Marshal a, MonadPush m) => K1 i a a1 -> m Unit gpush (K1 x) = push x {-# INLINABLE gpush #-} + + gpop :: (Marshal a, MonadPop m) => m (K1 i a a1) gpop = K1 <$> pop {-# INLINABLE gpop #-} instance (GMarshal f, GMarshal g) => GMarshal (f :*: g) where + gpush :: (GMarshal f, GMarshal g, MonadPush m) => (:*:) f g a -> m Unit gpush (a :*: b) = do gpush a gpush b {-# INLINABLE gpush #-} + + gpop :: (GMarshal f, GMarshal g, MonadPop m) => m ((:*:) f g a) gpop = (:*:) <$> gpop <*> gpop {-# INLINABLE gpop #-} instance GMarshal a => GMarshal (M1 i c a) where + gpush :: (GMarshal a, MonadPush m) => M1 i c a a1 -> m Unit gpush (M1 x) = gpush x {-# INLINABLE gpush #-} + + gpop :: (GMarshal a, MonadPop m) => m (M1 i c a a1) gpop = M1 <$> gpop {-# INLINABLE gpop #-} @@ -171,14 +204,14 @@ instance GMarshal a => GMarshal (M1 i c a) where -- consisting of only types that implement 'Marshal'. type SimpleProduct :: Type -> Constraint type family SimpleProduct a where - SimpleProduct a = (ProductLike a (Rep a), OnlyMarshallableFields (Rep a)) + SimpleProduct a = CTuple2 (ProductLike a (Rep a)) (OnlyMarshallableFields (Rep a)) type ProductLike :: Type -> (Type -> Type) -> Constraint type family ProductLike t f where - ProductLike t (a :*: b) = (ProductLike t a, ProductLike t b) + ProductLike t (a :*: b) = CTuple2 (ProductLike t a) (ProductLike t b) ProductLike t (M1 _ _ a) = ProductLike t a - ProductLike _ (K1 _ _) = () - ProductLike t (_ :+: _) = + ProductLike _ (K1 _ _) = CUnit + ProductLike t (_ :+: _) = TypeError ( 'Text "Error while deriving marshalling code for type " ':<>: 'ShowType t ':<>: 'Text ":" ':$$: 'Text "Cannot derive sum type, only product types are supported.") ProductLike t U1 = @@ -190,14 +223,14 @@ type family ProductLike t f where type OnlyMarshallableFields :: (Type -> Type) -> Constraint type family OnlyMarshallableFields f where - OnlyMarshallableFields (a :*: b) = (OnlyMarshallableFields a, OnlyMarshallableFields b) - OnlyMarshallableFields (a :+: b) = (OnlyMarshallableFields a, OnlyMarshallableFields b) + OnlyMarshallableFields (a :*: b) = CTuple2 (OnlyMarshallableFields a) (OnlyMarshallableFields b) + OnlyMarshallableFields (a :+: b) = CTuple2 (OnlyMarshallableFields a) (OnlyMarshallableFields b) OnlyMarshallableFields (M1 _ _ a) = OnlyMarshallableFields a - OnlyMarshallableFields U1 = () - OnlyMarshallableFields V1 = () - OnlyMarshallableFields k = OnlyMarshallableField k + OnlyMarshallableFields U1 = CUnit + OnlyMarshallableFields V1 = CUnit + OnlyMarshallableFields k = OnlyMarshallableField k type OnlyMarshallableField :: (Type -> Type) -> Constraint type family OnlyMarshallableField f where OnlyMarshallableField (M1 _ _ a) = OnlyMarshallableField a - OnlyMarshallableField (K1 _ a) = Marshal a + OnlyMarshallableField (K1 _ a) = Marshal a diff --git a/package.yaml b/package.yaml deleted file mode 100644 index dca145c..0000000 --- a/package.yaml +++ /dev/null @@ -1,167 +0,0 @@ -name: souffle-haskell -synopsis: Souffle Datalog bindings for Haskell -description: Souffle Datalog bindings for Haskell. -version: 4.0.0 -homepage: https://github.com/luc-tielen/souffle-haskell#README.md -license: MIT -author: Luc Tielen -maintainer: luc.tielen@gmail.com -copyright: 2022 Luc Tielen -category: Logic Programming, Foreign Binding, Bindings -github: luc-tielen/souffle-haskell -extra-doc-files: - - README.md - - CHANGELOG.md - - LICENSE -extra-source-files: - - cbits/**/*.h - - cbits/*.cpp - - cbits/souffle/LICENSE - -dependencies: - - base >= 4.12 && < 5 - - text >= 2.0.2 && < 3 - - vector <= 1.0 - -default-extensions: - - DerivingStrategies - - FlexibleContexts - - LambdaCase - - 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 - - -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 - -include-dirs: - - cbits - - cbits/souffle - -install-includes: - - souffle/CompiledSouffle.h - - souffle/RamTypes.h - - souffle/RecordTable.h - - souffle/datastructure/ConcurrentFlyweight.h - - souffle/datastructure/ConcurrentInsertOnlyHashMap.h - - souffle/utility/ParallelUtil.h - - souffle/utility/span.h - - souffle/SignalHandler.h - - souffle/SouffleInterface.h - - souffle/SymbolTable.h - - souffle/utility/MiscUtil.h - - souffle/utility/General.h - - souffle/utility/Iteration.h - - souffle/utility/Types.h - - souffle/utility/tinyformat.h - - souffle/utility/StreamUtil.h - - souffle/utility/ContainerUtil.h - - souffle/utility/DynamicCasting.h - - souffle/datastructure/BTreeDelete.h - - souffle/datastructure/BTreeUtil.h - - souffle/utility/CacheUtil.h - - souffle/datastructure/Brie.h - - souffle/datastructure/EquivalenceRelation.h - - souffle/datastructure/LambdaBTree.h - - souffle/datastructure/BTree.h - - souffle/datastructure/PiggyList.h - - souffle/datastructure/UnionFind.h - - souffle/datastructure/Table.h - - souffle/io/IOSystem.h - - souffle/io/ReadStream.h - - souffle/io/SerialisationStream.h - - souffle/utility/StringUtil.h - - souffle/utility/json11.h - - souffle/io/ReadStreamCSV.h - - souffle/utility/FileUtil.h - - souffle/io/gzfstream.h - - souffle/io/ReadStreamJSON.h - - souffle/io/WriteStream.h - - souffle/io/WriteStreamCSV.h - - souffle/io/WriteStreamJSON.h - - souffle/io/ReadStreamSQLite.h - - souffle/io/WriteStreamSQLite.h - - souffle/utility/EvaluatorUtil.h - -library: - source-dirs: lib - cxx-sources: cbits/*.cpp - cxx-options: - - -Wall - when: - - condition: os(linux) - extra-libraries: stdc++ - generated-other-modules: - - Paths_souffle_haskell - dependencies: - - mtl >= 2.0 && < 3 - - deepseq >= 1.4.4 && < 2 - - filepath >= 1.4.2 && < 2 - - process >= 1.6 && < 2 - - bytestring >= 0.10.10 && < 1 - - array <= 1.0 - - profunctors >= 5.6.2 && < 6 - - directory >= 1.3.3 && < 2 - - temporary >= 1.3 && < 2 - -tests: - souffle-haskell-test: - main: test.hs - source-dirs: tests - cxx-sources: tests/fixtures/*.cpp - when: - - condition: os(darwin) - extra-libraries: c++ - dependencies: - - hspec >= 2.6.1 && < 3.0.0 - - hspec-hedgehog == 0.* - - hedgehog == 1.* - - array <= 1.0 - - profunctors >= 5.6.2 && < 6 - - directory >= 1.3.3 && < 2 - - temporary >= 1.3 && < 2 - - souffle-haskell - cxx-options: - - -D__EMBEDDED_SOUFFLE__ - ghc-options: - - -Wno-missing-kind-signatures - - -Wno-operator-whitespace - -benchmarks: - souffle-haskell-benchmarks: - main: bench.hs - source-dirs: benchmarks - cxx-sources: benchmarks/fixtures/*.cpp - when: - - condition: os(darwin) - extra-libraries: c++ - dependencies: - - souffle-haskell - - criterion == 1.* - - deepseq >= 1.4.4 && < 2 - cxx-options: - - -D__EMBEDDED_SOUFFLE__ - - -std=c++17 - - -march=native - ghc-options: - - +RTS -N1 -RTS # Run benchmarks sequentially (parallel is not safe!) diff --git a/souffle b/souffle index ea4ebd4..01f1177 160000 --- a/souffle +++ b/souffle @@ -1 +1 @@ -Subproject commit ea4ebd45b56619f9362d5db9bb6b7783b4bbb24c +Subproject commit 01f11777b4b09329b8232466d82376e039ac1ba8 diff --git a/souffle-haskell.cabal b/souffle-haskell.cabal index bc46395..2bfeb23 100644 --- a/souffle-haskell.cabal +++ b/souffle-haskell.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.2 +cabal-version: 3.0 -- This file has been generated from package.yaml by hpack version 0.35.2. -- @@ -17,53 +17,16 @@ copyright: 2022 Luc Tielen license: MIT license-file: LICENSE build-type: Simple + extra-source-files: cbits/souffle.h - cbits/souffle/CompiledSouffle.h - cbits/souffle/datastructure/Brie.h - cbits/souffle/datastructure/BTree.h - cbits/souffle/datastructure/BTreeDelete.h - cbits/souffle/datastructure/BTreeUtil.h - cbits/souffle/datastructure/ConcurrentFlyweight.h - cbits/souffle/datastructure/ConcurrentInsertOnlyHashMap.h - cbits/souffle/datastructure/EquivalenceRelation.h - cbits/souffle/datastructure/LambdaBTree.h - cbits/souffle/datastructure/PiggyList.h - cbits/souffle/datastructure/Table.h - cbits/souffle/datastructure/UnionFind.h - cbits/souffle/io/gzfstream.h - cbits/souffle/io/IOSystem.h - cbits/souffle/io/ReadStream.h - cbits/souffle/io/ReadStreamCSV.h - cbits/souffle/io/ReadStreamJSON.h - cbits/souffle/io/ReadStreamSQLite.h - cbits/souffle/io/SerialisationStream.h - cbits/souffle/io/WriteStream.h - cbits/souffle/io/WriteStreamCSV.h - cbits/souffle/io/WriteStreamJSON.h - cbits/souffle/io/WriteStreamSQLite.h - cbits/souffle/RamTypes.h - cbits/souffle/RecordTable.h - cbits/souffle/SignalHandler.h - cbits/souffle/SouffleInterface.h - cbits/souffle/SymbolTable.h - cbits/souffle/utility/CacheUtil.h - cbits/souffle/utility/ContainerUtil.h - cbits/souffle/utility/DynamicCasting.h - cbits/souffle/utility/EvaluatorUtil.h - cbits/souffle/utility/FileUtil.h - cbits/souffle/utility/General.h - cbits/souffle/utility/Iteration.h - cbits/souffle/utility/json11.h - cbits/souffle/utility/MiscUtil.h - cbits/souffle/utility/ParallelUtil.h - cbits/souffle/utility/span.h - cbits/souffle/utility/StreamUtil.h - cbits/souffle/utility/StringUtil.h - cbits/souffle/utility/tinyformat.h - cbits/souffle/utility/Types.h + cbits/souffle/*.h + cbits/souffle/**/*.h cbits/souffle.cpp cbits/souffle/LICENSE + souffle/src/include/souffle/*.h + souffle/src/include/souffle/**/*.h + extra-doc-files: README.md CHANGELOG.md @@ -82,87 +45,44 @@ library Language.Souffle.Internal.Bindings Language.Souffle.Interpreted Language.Souffle.Marshal - other-modules: - Paths_souffle_haskell - autogen-modules: - Paths_souffle_haskell - hs-source-dirs: - lib + hs-source-dirs: lib default-extensions: - DerivingStrategies - FlexibleContexts - LambdaCase - 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 -Wno-operator-whitespace -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits + Arrows + DefaultSignatures + DeriveAnyClass + DerivingVia + NoListTuplePuns + NoImplicitPrelude + OverloadedStrings + TypeFamilies + UndecidableInstances + TypeAbstractions + AllowAmbiguousTypes + RequiredTypeArguments + ghc-options: -Wall cxx-options: -std=c++17 -Wall include-dirs: cbits cbits/souffle - install-includes: - souffle/CompiledSouffle.h - souffle/RamTypes.h - souffle/RecordTable.h - souffle/datastructure/ConcurrentFlyweight.h - souffle/datastructure/ConcurrentInsertOnlyHashMap.h - souffle/utility/ParallelUtil.h - souffle/utility/span.h - souffle/SignalHandler.h - souffle/SouffleInterface.h - souffle/SymbolTable.h - souffle/utility/MiscUtil.h - souffle/utility/General.h - souffle/utility/Iteration.h - souffle/utility/Types.h - souffle/utility/tinyformat.h - souffle/utility/StreamUtil.h - souffle/utility/ContainerUtil.h - souffle/utility/DynamicCasting.h - souffle/datastructure/BTreeDelete.h - souffle/datastructure/BTreeUtil.h - souffle/utility/CacheUtil.h - souffle/datastructure/Brie.h - souffle/datastructure/EquivalenceRelation.h - souffle/datastructure/LambdaBTree.h - souffle/datastructure/BTree.h - souffle/datastructure/PiggyList.h - souffle/datastructure/UnionFind.h - souffle/datastructure/Table.h - souffle/io/IOSystem.h - souffle/io/ReadStream.h - souffle/io/SerialisationStream.h - souffle/utility/StringUtil.h - souffle/utility/json11.h - souffle/io/ReadStreamCSV.h - souffle/utility/FileUtil.h - souffle/io/gzfstream.h - souffle/io/ReadStreamJSON.h - souffle/io/WriteStream.h - souffle/io/WriteStreamCSV.h - souffle/io/WriteStreamJSON.h - souffle/io/ReadStreamSQLite.h - souffle/io/WriteStreamSQLite.h - souffle/utility/EvaluatorUtil.h - cxx-sources: - cbits/souffle.cpp + souffle + cxx-sources: cbits/souffle.cpp build-depends: - array <=1.0 - , base >=4.12 && <5 - , bytestring >=0.10.10 && <1 - , deepseq >=1.4.4 && <2 - , directory >=1.3.3 && <2 - , filepath >=1.4.2 && <2 - , mtl >=2.0 && <3 - , process >=1.6 && <2 - , profunctors >=5.6.2 && <6 - , temporary >=1.3 && <2 - , text >=2.0.2 && <3 - , vector <=1.0 - default-language: Haskell2010 + array <=1.0, + base >=4.12 && <5, + bytestring >=0.10.10 && <1, + deepseq >=1.4.4 && <2, + directory >=1.3.3 && <2, + filepath >=1.4.2 && <2, + mtl >=2.0 && <3, + process >=1.6 && <2, + profunctors >=5.6.2 && <6, + temporary >=1.3 && <2, + text >=2.0.2 && <3, + vector <=1.0, + ghc-prim + default-language: GHC2024 if os(linux) - extra-libraries: - stdc++ + extra-libraries: stdc++ test-suite souffle-haskell-test type: exitcode-stdio-1.0 @@ -173,163 +93,71 @@ test-suite souffle-haskell-test Test.Language.Souffle.DerivingViaSpec Test.Language.Souffle.InterpretedSpec Test.Language.Souffle.MarshalSpec - Paths_souffle_haskell - autogen-modules: - Paths_souffle_haskell - hs-source-dirs: - tests + hs-source-dirs: tests default-extensions: - DerivingStrategies - FlexibleContexts - LambdaCase - 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 -Wno-operator-whitespace -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits -Wno-missing-kind-signatures -Wno-operator-whitespace + Arrows + DefaultSignatures + DeriveAnyClass + DerivingVia + NoListTuplePuns + NoImplicitPrelude + OverloadedStrings + TypeFamilies + UndecidableInstances + ghc-options: -Wall cxx-options: -std=c++17 -D__EMBEDDED_SOUFFLE__ include-dirs: cbits cbits/souffle - install-includes: - souffle/CompiledSouffle.h - souffle/RamTypes.h - souffle/RecordTable.h - souffle/datastructure/ConcurrentFlyweight.h - souffle/datastructure/ConcurrentInsertOnlyHashMap.h - souffle/utility/ParallelUtil.h - souffle/utility/span.h - souffle/SignalHandler.h - souffle/SouffleInterface.h - souffle/SymbolTable.h - souffle/utility/MiscUtil.h - souffle/utility/General.h - souffle/utility/Iteration.h - souffle/utility/Types.h - souffle/utility/tinyformat.h - souffle/utility/StreamUtil.h - souffle/utility/ContainerUtil.h - souffle/utility/DynamicCasting.h - souffle/datastructure/BTreeDelete.h - souffle/datastructure/BTreeUtil.h - souffle/utility/CacheUtil.h - souffle/datastructure/Brie.h - souffle/datastructure/EquivalenceRelation.h - souffle/datastructure/LambdaBTree.h - souffle/datastructure/BTree.h - souffle/datastructure/PiggyList.h - souffle/datastructure/UnionFind.h - souffle/datastructure/Table.h - souffle/io/IOSystem.h - souffle/io/ReadStream.h - souffle/io/SerialisationStream.h - souffle/utility/StringUtil.h - souffle/utility/json11.h - souffle/io/ReadStreamCSV.h - souffle/utility/FileUtil.h - souffle/io/gzfstream.h - souffle/io/ReadStreamJSON.h - souffle/io/WriteStream.h - souffle/io/WriteStreamCSV.h - souffle/io/WriteStreamJSON.h - souffle/io/ReadStreamSQLite.h - souffle/io/WriteStreamSQLite.h - souffle/utility/EvaluatorUtil.h cxx-sources: tests/fixtures/edge_cases.cpp tests/fixtures/path.cpp tests/fixtures/round_trip.cpp build-depends: - array <=1.0 - , base >=4.12 && <5 - , directory >=1.3.3 && <2 - , hedgehog ==1.* - , hspec >=2.6.1 && <3.0.0 - , hspec-hedgehog ==0.* - , profunctors >=5.6.2 && <6 - , souffle-haskell - , temporary >=1.3 && <2 - , text >=2.0.2 && <3 - , vector <=1.0 - default-language: Haskell2010 + array <=1.0, + base >=4.12 && <5, + directory >=1.3.3 && <2, + hedgehog ==1.*, + hspec >=2.6.1 && <3.0.0, + hspec-hedgehog ==0.*, + profunctors >=5.6.2 && <6, + souffle-haskell, + temporary >=1.3 && <2, + text >=2.0.2 && <3, + vector <=1.0, + ghc-prim + default-language: GHC2024 if os(darwin) - extra-libraries: - c++ + extra-libraries: c++ benchmark souffle-haskell-benchmarks type: exitcode-stdio-1.0 main-is: bench.hs - other-modules: - Paths_souffle_haskell - autogen-modules: - Paths_souffle_haskell - hs-source-dirs: - benchmarks + hs-source-dirs: benchmarks default-extensions: - DerivingStrategies - FlexibleContexts - LambdaCase - 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 -Wno-operator-whitespace -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits +RTS -N1 -RTS + Arrows + DefaultSignatures + DeriveAnyClass + DerivingVia + NoListTuplePuns + NoImplicitPrelude + OverloadedStrings + TypeFamilies + UndecidableInstances + ghc-options: -Wall cxx-options: -std=c++17 -D__EMBEDDED_SOUFFLE__ -std=c++17 -march=native include-dirs: cbits cbits/souffle - install-includes: - souffle/CompiledSouffle.h - souffle/RamTypes.h - souffle/RecordTable.h - souffle/datastructure/ConcurrentFlyweight.h - souffle/datastructure/ConcurrentInsertOnlyHashMap.h - souffle/utility/ParallelUtil.h - souffle/utility/span.h - souffle/SignalHandler.h - souffle/SouffleInterface.h - souffle/SymbolTable.h - souffle/utility/MiscUtil.h - souffle/utility/General.h - souffle/utility/Iteration.h - souffle/utility/Types.h - souffle/utility/tinyformat.h - souffle/utility/StreamUtil.h - souffle/utility/ContainerUtil.h - souffle/utility/DynamicCasting.h - souffle/datastructure/BTreeDelete.h - souffle/datastructure/BTreeUtil.h - souffle/utility/CacheUtil.h - souffle/datastructure/Brie.h - souffle/datastructure/EquivalenceRelation.h - souffle/datastructure/LambdaBTree.h - souffle/datastructure/BTree.h - souffle/datastructure/PiggyList.h - souffle/datastructure/UnionFind.h - souffle/datastructure/Table.h - souffle/io/IOSystem.h - souffle/io/ReadStream.h - souffle/io/SerialisationStream.h - souffle/utility/StringUtil.h - souffle/utility/json11.h - souffle/io/ReadStreamCSV.h - souffle/utility/FileUtil.h - souffle/io/gzfstream.h - souffle/io/ReadStreamJSON.h - souffle/io/WriteStream.h - souffle/io/WriteStreamCSV.h - souffle/io/WriteStreamJSON.h - souffle/io/ReadStreamSQLite.h - souffle/io/WriteStreamSQLite.h - souffle/utility/EvaluatorUtil.h - cxx-sources: - benchmarks/fixtures/bench.cpp + cxx-sources: benchmarks/fixtures/bench.cpp build-depends: - base >=4.12 && <5 - , criterion ==1.* - , deepseq >=1.4.4 && <2 - , souffle-haskell - , text >=2.0.2 && <3 - , vector <=1.0 - default-language: Haskell2010 + base >=4.12 && <5, + criterion ==1.*, + deepseq >=1.4.4 && <2, + souffle-haskell, + text >=2.0.2 && <3, + vector <=1.0, + ghc-prim + default-language: GHC2024 if os(darwin) - extra-libraries: - c++ + extra-libraries: c++ diff --git a/tests/Test/Language/Souffle/AnalysisSpec.hs b/tests/Test/Language/Souffle/AnalysisSpec.hs index df4153c..b56932e 100644 --- a/tests/Test/Language/Souffle/AnalysisSpec.hs +++ b/tests/Test/Language/Souffle/AnalysisSpec.hs @@ -1,19 +1,24 @@ -{-# LANGUAGE DataKinds, TypeFamilies, DeriveGeneric, Arrows #-} - module Test.Language.Souffle.AnalysisSpec ( module Test.Language.Souffle.AnalysisSpec ) where -import Prelude hiding ((.), id) -import Control.Arrow -import Control.Category -import Test.Hspec -import Data.Profunctor -import GHC.Generics -import Control.Monad.IO.Class -import Language.Souffle.Analysis +import Control.Arrow (Arrow (..), returnA) +import Control.Category (Category (..)) +import Control.Monad.IO.Class (MonadIO (..)) + +import Data.List (List) +import Data.Profunctor (Profunctor (..)) + +import GHC.Generics (Generic) +import GHC.Tuple (Tuple2, Unit) + +import Language.Souffle.Analysis (Analysis, execAnalysis, mkAnalysis) import qualified Language.Souffle.Interpreted as Souffle +import Prelude hiding (id, (.)) + +import Test.Hspec (Spec, describe, it, parallel, shouldBe) + data Path = Path data Edge = Edge String String @@ -23,31 +28,37 @@ data Reachable = Reachable String String deriving stock (Eq, Show, Generic) instance Souffle.Program Path where - type ProgramFacts Path = '[Edge, Reachable] + type ProgramFacts Path = [Edge, Reachable] + + programName :: Path -> String programName = const "path" instance Souffle.Fact Edge where - type FactDirection Edge = 'Souffle.InputOutput - factName = const "edge" + type FactDirection Edge = Souffle.InputOutput + + factName :: String + factName = "edge" instance Souffle.Fact Reachable where - type FactDirection Reachable = 'Souffle.Output - factName = const "reachable" + type FactDirection Reachable = Souffle.Output + + factName :: String + factName = "reachable" instance Souffle.Marshal Edge instance Souffle.Marshal Reachable -data Results = Results [Reachable] [Edge] +data Results = Results (List Reachable) (List Edge) deriving stock (Eq, Show) pathAnalysis :: Souffle.Handle Path - -> Analysis Souffle.SouffleM [Edge] [Reachable] + -> Analysis Souffle.SouffleM (List Edge) (List Reachable) pathAnalysis h = mkAnalysis (Souffle.addFacts h) (Souffle.run h) (Souffle.getFacts h) -- A little bit silly, but good enough to test different forms of application with pathAnalysis' :: Souffle.Handle Path - -> Analysis Souffle.SouffleM [Edge] [Edge] + -> Analysis Souffle.SouffleM (List Edge) (List Edge) pathAnalysis' h = mkAnalysis (Souffle.addFacts h) (Souffle.run h) (Souffle.getFacts h) @@ -57,39 +68,41 @@ newtype StringFact = StringFact String deriving stock (Eq, Show, Generic) instance Souffle.Program RoundTrip where - type ProgramFacts RoundTrip = '[StringFact] + type ProgramFacts RoundTrip = [StringFact] + programName :: RoundTrip -> String programName = const "round_trip" instance Souffle.Fact StringFact where - type FactDirection StringFact = 'Souffle.InputOutput + type FactDirection StringFact = Souffle.InputOutput - factName = const "string_fact" + factName :: String + factName = "string_fact" instance Souffle.Marshal StringFact roundTripAnalysis :: Souffle.Handle RoundTrip - -> Analysis Souffle.SouffleM [Reachable] [StringFact] + -> Analysis Souffle.SouffleM (List Reachable) (List StringFact) roundTripAnalysis h = mkAnalysis addFacts (Souffle.run h) (Souffle.getFacts h) where addFacts rs = do Souffle.addFacts h $ map (\(Reachable a _) -> StringFact a) rs -withSouffle :: Souffle.Program a => a -> (Souffle.Handle a -> Souffle.SouffleM ()) -> IO () +withSouffle :: Souffle.Program a => a -> (Souffle.Handle a -> Souffle.SouffleM Unit) -> IO Unit withSouffle prog f = Souffle.runSouffle prog $ \case Nothing -> error "Failed to load program" Just h -> f h -edges :: [Edge] +edges :: (List Edge) edges = [Edge "a" "b", Edge "b" "c", Edge "b" "d", Edge "d" "e"] spec :: Spec spec = describe "composing analyses" $ parallel $ do it "supports fmap" $ do withSouffle Path $ \h -> do - let analysis = pathAnalysis h + let analysis = pathAnalysis h analysis' = fmap length analysis count <- execAnalysis analysis' edges liftIO $ count `shouldBe` 8 @@ -140,7 +153,7 @@ spec = describe "composing analyses" $ parallel $ do it "supports mempty" $ do withSouffle Path $ \_ -> do - let analysis :: Analysis Souffle.SouffleM [Edge] [Reachable] + let analysis :: Analysis Souffle.SouffleM (List Edge) (List Reachable) analysis = mempty rs <- execAnalysis analysis [Edge "a" "b", Edge "b" "c"] liftIO $ rs `shouldBe` [] @@ -158,7 +171,7 @@ spec = describe "composing analyses" $ parallel $ do describe "analysis used as a category" $ parallel $ do it "supports 'id'" $ do withSouffle Path $ \_ -> do - let analysis :: Analysis Souffle.SouffleM [Edge] [Edge] + let analysis :: Analysis Souffle.SouffleM (List Edge) (List Edge) analysis = id edges' <- execAnalysis analysis edges liftIO $ edges' `shouldBe` edges @@ -187,13 +200,13 @@ spec = describe "composing analyses" $ parallel $ do let analysis :: Analysis Souffle.SouffleM Int Int analysis = arr (+1) result1 <- execAnalysis analysis 41 - result2 <- execAnalysis (arr id) 41 + result2 <- execAnalysis (arr id) (41 :: Integer) liftIO $ result1 `shouldBe` 42 liftIO $ result2 `shouldBe` 41 it "supports 'first'" $ do withSouffle Path $ \_ -> do - let analysis :: Analysis Souffle.SouffleM (Int, Bool) (Int, Bool) + let analysis :: Analysis Souffle.SouffleM (Tuple2 Int Bool) (Tuple2 Int Bool) analysis = first (arr (+1)) input = (41, True) result <- execAnalysis analysis input @@ -201,7 +214,7 @@ spec = describe "composing analyses" $ parallel $ do it "supports 'second'" $ do withSouffle Path $ \_ -> do - let analysis :: Analysis Souffle.SouffleM (Bool, Int) (Bool, Int) + let analysis :: Analysis Souffle.SouffleM (Tuple2 Bool Int) (Tuple2 Bool Int) analysis = second (arr (+1)) input = (True, 41) result <- execAnalysis analysis input @@ -209,7 +222,7 @@ spec = describe "composing analyses" $ parallel $ do it "supports (***)" $ do withSouffle Path $ \_ -> do - let analysis :: Analysis Souffle.SouffleM (Bool, Int) (Bool, Int) + let analysis :: Analysis Souffle.SouffleM (Tuple2 Bool Int) (Tuple2 Bool Int) analysis = arr not *** arr (+1) input = (True, 41) result <- execAnalysis analysis input @@ -217,7 +230,7 @@ spec = describe "composing analyses" $ parallel $ do it "supports (&&&)" $ do withSouffle Path $ \_ -> do - let analysis :: Analysis Souffle.SouffleM Int (Bool, Int) + let analysis :: Analysis Souffle.SouffleM Int (Tuple2 Bool Int) analysis = arr (== 1000) &&& arr (+1) input = 41 result <- execAnalysis analysis input diff --git a/tests/Test/Language/Souffle/CompiledSpec.hs b/tests/Test/Language/Souffle/CompiledSpec.hs index adf40ca..d8a1867 100644 --- a/tests/Test/Language/Souffle/CompiledSpec.hs +++ b/tests/Test/Language/Souffle/CompiledSpec.hs @@ -1,16 +1,31 @@ -{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies, DeriveGeneric #-} - module Test.Language.Souffle.CompiledSpec ( module Test.Language.Souffle.CompiledSpec ) where -import Test.Hspec -import GHC.Generics -import Data.Maybe -import qualified Data.Array as A -import qualified Data.Vector as V +import Control.Applicative (Applicative (..)) + +import qualified Data.Array as A +import Data.Bool (Bool (..)) +import Data.Eq (Eq) +import Data.Foldable (Foldable (..)) +import Data.Function (const, ($)) +import Data.Functor ((<$>)) +import Data.Int (Int) +import Data.List (List) +import Data.Maybe (Maybe (..), fromJust, isJust) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.String (String) +import qualified Data.Vector as V + +import GHC.Generics (Generic) + import qualified Language.Souffle.Compiled as Souffle +import Test.Hspec (Spec, describe, it, parallel, shouldBe) + +import Text.Show (Show) + data Path = Path data Edge = Edge String String @@ -20,16 +35,22 @@ data Reachable = Reachable String String deriving stock (Eq, Show, Generic) instance Souffle.Program Path where - type ProgramFacts Path = '[Edge, Reachable] + type ProgramFacts Path = [Edge, Reachable] + + programName :: Path -> String programName = const "path" instance Souffle.Fact Edge where - type FactDirection Edge = 'Souffle.InputOutput - factName = const "edge" + type FactDirection Edge = Souffle.InputOutput + + factName :: String + factName = "edge" instance Souffle.Fact Reachable where - type FactDirection Reachable = 'Souffle.Output - factName = const "reachable" + type FactDirection Reachable = Souffle.Output + + factName :: String + factName = "reachable" instance Souffle.Marshal Edge instance Souffle.Marshal Reachable @@ -38,7 +59,9 @@ instance Souffle.Marshal Reachable data BadPath = BadPath instance Souffle.Program BadPath where - type ProgramFacts BadPath = '[Edge, Reachable] + type ProgramFacts BadPath = [Edge, Reachable] + + programName :: BadPath -> String programName = const "bad_path" @@ -109,7 +132,7 @@ spec = describe "Souffle API" $ parallel $ do edges <- Souffle.runSouffle Path $ \handle -> do let prog = fromJust handle Souffle.getFacts prog - edges `shouldBe` ([] :: [Edge]) + edges `shouldBe` ([] :: List Edge) describe "addFact" $ parallel $ it "adds a fact" $ do diff --git a/tests/Test/Language/Souffle/DerivingViaSpec.hs b/tests/Test/Language/Souffle/DerivingViaSpec.hs index 6c0c758..0f8bf94 100644 --- a/tests/Test/Language/Souffle/DerivingViaSpec.hs +++ b/tests/Test/Language/Souffle/DerivingViaSpec.hs @@ -1,30 +1,36 @@ -{-# LANGUAGE UndecidableInstances, DataKinds, DeriveGeneric, DeriveAnyClass, DerivingVia #-} - module Test.Language.Souffle.DerivingViaSpec ( module Test.Language.Souffle.DerivingViaSpec ) where -import Test.Hspec -import GHC.Generics -import Data.Maybe +import Data.Eq (Eq) +import Data.Function (($)) +import Data.Maybe (fromJust) +import Data.String (String) + +import GHC.Generics (Generic) + import qualified Language.Souffle.Interpreted as Souffle +import Test.Hspec (Spec, describe, it, shouldBe) + +import Text.Show (Show) + data Path = Path deriving Souffle.Program - via Souffle.ProgramOptions Path "path" '[Edge, Reachable] + via Souffle.ProgramOptions Path "path" [Edge, Reachable] data Edge = Edge String String deriving stock (Eq, Show, Generic) deriving anyclass Souffle.Marshal deriving Souffle.Fact - via Souffle.FactOptions Edge "edge" 'Souffle.InputOutput + via Souffle.FactOptions Edge "edge" Souffle.InputOutput data Reachable = Reachable String String deriving stock (Eq, Show, Generic) deriving anyclass Souffle.Marshal deriving Souffle.Fact - via Souffle.FactOptions Reachable "reachable" 'Souffle.Output + via Souffle.FactOptions Reachable "reachable" Souffle.Output spec :: Spec diff --git a/tests/Test/Language/Souffle/InterpretedSpec.hs b/tests/Test/Language/Souffle/InterpretedSpec.hs index 5bad187..eaf8b30 100644 --- a/tests/Test/Language/Souffle/InterpretedSpec.hs +++ b/tests/Test/Language/Souffle/InterpretedSpec.hs @@ -1,20 +1,34 @@ - -{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies, DeriveGeneric #-} - module Test.Language.Souffle.InterpretedSpec ( module Test.Language.Souffle.InterpretedSpec ) where -import Test.Hspec -import GHC.Generics -import Data.Maybe -import Control.Monad.IO.Class (liftIO) -import System.Directory -import System.IO.Temp -import qualified Data.Array as A -import qualified Data.Vector as V +import Control.Applicative (Applicative (..)) +import Control.Monad.IO.Class (liftIO) + +import qualified Data.Array as A +import Data.Bool (Bool (..)) +import Data.Eq (Eq) +import Data.Foldable (Foldable (..)) +import Data.Function (const, ($), (.)) +import Data.Int (Int) +import Data.List (List) +import Data.Maybe (Maybe (..), fromJust, isJust) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.String (String) +import qualified Data.Vector as V + +import GHC.Generics (Generic) + import qualified Language.Souffle.Interpreted as Souffle +import System.Directory (doesDirectoryExist, listDirectory) +import System.IO (FilePath, IO) +import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) + +import Test.Hspec (Spec, describe, it, parallel, shouldBe, shouldNotBe) + +import Text.Show (Show) data Path = Path @@ -29,26 +43,36 @@ data Reachable = Reachable String String deriving stock (Eq, Show, Generic) instance Souffle.Fact Edge where - type FactDirection Edge = 'Souffle.InputOutput - factName = const "edge" + type FactDirection Edge = Souffle.InputOutput + + factName :: String + factName = "edge" instance Souffle.Fact Reachable where - type FactDirection Reachable = 'Souffle.Output - factName = const "reachable" + type FactDirection Reachable = Souffle.Output + + factName :: String + factName = "reachable" instance Souffle.Marshal Edge instance Souffle.Marshal Reachable instance Souffle.Program Path where - type ProgramFacts Path = '[Edge, Reachable] + type ProgramFacts Path = [Edge, Reachable] + + programName :: Path -> String programName = const "path" instance Souffle.Program PathNoInput where - type ProgramFacts PathNoInput = '[Edge, Reachable] + type ProgramFacts PathNoInput = [Edge, Reachable] + + programName :: PathNoInput -> String programName = const "path_no_input" instance Souffle.Program BadPath where - type ProgramFacts BadPath = '[Edge, Reachable] + type ProgramFacts BadPath = [Edge, Reachable] + + programName :: BadPath -> String programName = const "bad_path" getTestTemporaryDirectory :: IO FilePath @@ -100,7 +124,7 @@ spec = describe "Souffle API" $ parallel $ do it "returns no facts in case program hasn't run yet" $ do edges <- Souffle.runSouffle Path $ Souffle.getFacts . fromJust - edges `shouldBe` ([] :: [Edge]) + edges `shouldBe` ([] :: List Edge) it "can retrieve facts from custom output directory" $ do cfg <- Souffle.defaultConfig diff --git a/tests/Test/Language/Souffle/MarshalSpec.hs b/tests/Test/Language/Souffle/MarshalSpec.hs index 8beb298..0527e30 100644 --- a/tests/Test/Language/Souffle/MarshalSpec.hs +++ b/tests/Test/Language/Souffle/MarshalSpec.hs @@ -1,30 +1,53 @@ -{-# LANGUAGE DeriveGeneric, TypeFamilies, DataKinds, RankNTypes #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-} module Test.Language.Souffle.MarshalSpec ( module Test.Language.Souffle.MarshalSpec ) where -import Test.Hspec -import Test.Hspec.Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import GHC.Generics -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text -import Data.Int -import Data.Word -import Data.Maybe ( fromJust ) -import Control.Monad.IO.Class ( liftIO ) -import Control.Monad -import Language.Souffle.Marshal -import qualified Language.Souffle.Marshal as Souffle -import qualified Language.Souffle.Class as Souffle -import qualified Language.Souffle.Compiled as Compiled +import Control.Applicative (Applicative (..)) +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) + +import Data.Bool (Bool (True)) +import Data.Bounded (Bounded (..)) +import Data.Eq (Eq) +import Data.Function (const, ($)) +import Data.Functor ((<$>)) +import Data.Int (Int32) +import Data.List (List) +import Data.Maybe (Maybe (..), fromJust) +import Data.Ord (Ord (..)) +import Data.String (IsString, String) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Void (Void) +import Data.Word (Word32) + +import GHC.Float (Float) +import GHC.Generics (Generic) +import GHC.Integer (Integer) +import GHC.Num (Num (..)) +import GHC.Tuple (Tuple3) + +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import qualified Language.Souffle.Class as Souffle +import qualified Language.Souffle.Compiled as Compiled import qualified Language.Souffle.Interpreted as Interpreted -import Data.String (IsString) -import Data.Void (Void) +import Language.Souffle.Marshal (Marshal) +import qualified Prelude as Prelude + +import System.IO (IO) + +import Test.Hspec (Spec, describe, it, parallel, shouldBe) +import Test.Hspec.Hedgehog (PropertyT, forAll, hedgehog, (===)) + +import Text.Show (Show) + +type f $ a = f a +infixl 9 type $ data Edge = Edge String String deriving stock (Eq, Show, Generic) @@ -57,7 +80,7 @@ data EdgeMixed = EdgeMixed Text Vertex data EdgeRecord = EdgeRecord { fromNode :: Text - , toNode :: Text + , toNode :: Text } deriving stock (Eq, Show, Generic) data IntsAndStrings = IntsAndStrings Text Int32 Text @@ -112,36 +135,52 @@ newtype FloatFact = FloatFact Float deriving stock (Eq, Show, Generic) instance Souffle.Fact StringFact where - type FactDirection StringFact = 'Souffle.InputOutput - factName = const "string_fact" + type FactDirection StringFact = Souffle.InputOutput + + factName :: String + factName = "string_fact" instance Souffle.Fact TextFact where - type FactDirection TextFact = 'Souffle.InputOutput - factName = const "string_fact" + type FactDirection TextFact = Souffle.InputOutput + + factName :: String + factName = "string_fact" instance Souffle.Fact LazyTextFact where - type FactDirection LazyTextFact = 'Souffle.InputOutput - factName = const "string_fact" + type FactDirection LazyTextFact = Souffle.InputOutput + + factName :: String + factName = "string_fact" instance Souffle.Fact Int32Fact where - type FactDirection Int32Fact = 'Souffle.InputOutput - factName = const "number_fact" + type FactDirection Int32Fact = Souffle.InputOutput + + factName :: String + factName = "number_fact" instance Souffle.Fact Word32Fact where - type FactDirection Word32Fact = 'Souffle.InputOutput - factName = const "unsigned_fact" + type FactDirection Word32Fact = Souffle.InputOutput + + factName :: String + factName = "unsigned_fact" instance Souffle.Fact FloatFact where - type FactDirection FloatFact = 'Souffle.InputOutput - factName = const "float_fact" + type FactDirection FloatFact = Souffle.InputOutput + + factName :: String + factName = "float_fact" instance Souffle.Fact NestedNewtype where - type FactDirection NestedNewtype = 'Souffle.InputOutput - factName = const "large_record" + type FactDirection NestedNewtype = Souffle.InputOutput + + factName :: String + factName = "large_record" instance Souffle.Fact NestedRecord where - type FactDirection NestedRecord = 'Souffle.InputOutput - factName = const "large_record" + type FactDirection NestedRecord = Souffle.InputOutput + + factName :: String + factName = "large_record" instance Souffle.Marshal StringFact instance Souffle.Marshal TextFact @@ -152,7 +191,9 @@ instance Souffle.Marshal FloatFact instance Souffle.Program RoundTrip where type ProgramFacts RoundTrip = - '[StringFact, TextFact, LazyTextFact, Int32Fact, Word32Fact, FloatFact, NestedNewtype, NestedRecord] + [StringFact, TextFact, LazyTextFact, Int32Fact, Word32Fact, FloatFact, NestedNewtype, NestedRecord] + + programName :: RoundTrip -> String programName = const "round_trip" type RoundTripAction @@ -160,6 +201,7 @@ type RoundTripAction => Souffle.ContainsInputFact RoundTrip a => Souffle.ContainsOutputFact RoundTrip a => Compiled.Submit a + => Show a => a -> PropertyT IO a @@ -182,46 +224,68 @@ data NoStrings a = NoStrings Word32 Int32 Float 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 ] + + programName :: EdgeCases -> String programName = const "edge_cases" instance Souffle.Fact (EmptyStrings String) where - type FactDirection (EmptyStrings String) = 'Souffle.InputOutput - factName = const "empty_strings" + type FactDirection (EmptyStrings String) = Souffle.InputOutput + + factName :: String + factName = "empty_strings" instance Souffle.Fact (EmptyStrings T.Text) where - type FactDirection (EmptyStrings T.Text) = 'Souffle.InputOutput - factName = const "empty_strings" + type FactDirection (EmptyStrings T.Text) = Souffle.InputOutput + + factName :: String + factName = "empty_strings" instance Souffle.Fact (EmptyStrings TL.Text) where - type FactDirection (EmptyStrings TL.Text) = 'Souffle.InputOutput - factName = const "empty_strings" + type FactDirection (EmptyStrings TL.Text) = Souffle.InputOutput + + factName :: String + factName = "empty_strings" instance Souffle.Fact (LongStrings String) where - type FactDirection (LongStrings String) = 'Souffle.InputOutput - factName = const "long_strings" + type FactDirection (LongStrings String) = Souffle.InputOutput + + factName :: String + factName = "long_strings" instance Souffle.Fact (LongStrings T.Text) where - type FactDirection (LongStrings T.Text) = 'Souffle.InputOutput - factName = const "long_strings" + type FactDirection (LongStrings T.Text) = Souffle.InputOutput + + factName :: String + factName = "long_strings" instance Souffle.Fact (LongStrings TL.Text) where - type FactDirection (LongStrings TL.Text) = 'Souffle.InputOutput - factName = const "long_strings" + type FactDirection (LongStrings TL.Text) = Souffle.InputOutput + + factName :: String + factName = "long_strings" instance Souffle.Fact (Unicode String) where - type FactDirection (Unicode String) = 'Souffle.InputOutput - factName = const "unicode" + type FactDirection (Unicode String) = Souffle.InputOutput + + factName :: String + factName = "unicode" instance Souffle.Fact (Unicode T.Text) where - type FactDirection (Unicode T.Text) = 'Souffle.InputOutput - factName = const "unicode" + type FactDirection (Unicode T.Text) = Souffle.InputOutput + + factName :: String + factName = "unicode" instance Souffle.Fact (Unicode TL.Text) where - type FactDirection (Unicode TL.Text) = 'Souffle.InputOutput - factName = const "unicode" + type FactDirection (Unicode TL.Text) = Souffle.InputOutput + + factName :: String + factName = "unicode" instance Souffle.Fact (NoStrings a) where - type FactDirection (NoStrings _) = 'Souffle.InputOutput - factName = const "no_strings" + type FactDirection (NoStrings _) = Souffle.InputOutput + + factName :: String + factName = "no_strings" instance Marshal (EmptyStrings String) instance Marshal (EmptyStrings T.Text) @@ -235,12 +299,13 @@ instance Marshal (Unicode TL.Text) instance Marshal (NoStrings a) + spec :: Spec spec = describe "Marshalling" $ parallel $ do describe "Auto-deriving marshalling code" $ it "can generate code for all instances in this file" $ -- If this file compiles, then the test has already passed - 42 `shouldBe` 42 + 42 `shouldBe` (42 :: Integer) roundTripSpecs edgeCaseSpecs @@ -321,204 +386,174 @@ roundTripSpecs = describe "data transfer between Haskell and Souffle" $ parallel Compiled.run prog Prelude.head <$> Compiled.getFacts prog +factsTest :: IsString a => List (EmptyStrings a) +factsTest = [EmptyStrings "" "" 42, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 42] + +factsAddTest :: IsString a => List (EmptyStrings a) +factsAddTest = [EmptyStrings "" "" 1, EmptyStrings "" "" 42, EmptyStrings "" "abc" 2, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 3, EmptyStrings "abc" "" 42] + +unicodeTest :: IsString a => Tuple3 (List $ Unicode a) (Maybe $ Unicode a) (Maybe $ Unicode a) +unicodeTest = ([ Unicode "∀", Unicode "∀∀" ], Nothing, Nothing) + +factsUnicodeTest :: IsString a => List (Unicode a) +factsUnicodeTest = [Unicode "∀", Unicode "∀∀", Unicode "≂", Unicode "⌀", Unicode "⌀⌀"] + +longString :: IsString a => a +longString = "long_string_from_DL:...............................................................................................................................................................................................................................................................................................end" + +runGetFacts + :: ( forall {k} f (a :: k) . + ( Souffle.Fact (f a) + , Souffle.ContainsOutputFact EdgeCases (f a)) + => IO (List (f a))) + -> Spec +runGetFacts getFacts = do + it "correctly marshals facts with number-like types" $ do + facts <- getFacts @NoStrings @Void + facts + `shouldBe` [ NoStrings 42 (-100) 1.5 + , NoStrings 123 (-456) 3.14 + ] + it "correctly marshals facts with empty Strings" $ do + facts <- getFacts @EmptyStrings @String + facts `shouldBe` factsTest + + it "correctly marshals facts with empty Texts" $ do + facts <- getFacts @EmptyStrings @T.Text + facts `shouldBe` factsTest + + it "correctly marshals facts with empty lazy Texts" $ do + facts <- getFacts @EmptyStrings @TL.Text + facts `shouldBe` factsTest + + it "correctly marshals facts really with long (>255 chars) String" $ do + facts <- getFacts @LongStrings @String + facts `shouldBe` [ LongStrings longString ] + + it "correctly marshals facts really with long (>255 chars) Text" $ do + facts <- getFacts @LongStrings @T.Text + facts `shouldBe` [ LongStrings longString ] + + it "correctly marshals facts really with long (>255 chars) lazy Text" $ do + facts <- getFacts @LongStrings @TL.Text + facts `shouldBe` [ LongStrings longString ] + +runGetUnicodeFacts + :: ( forall a. + ( IsString a + , Eq a + , Souffle.Fact (Unicode a) + , Souffle.ContainsOutputFact EdgeCases (Unicode a) + , Compiled.Submit (Unicode a)) + => IO $ Tuple3 (List $ Unicode a) (Maybe $ Unicode a) (Maybe $ Unicode a)) + -> Spec +runGetUnicodeFacts getUnicodeFacts = do + it "correctly marshals facts containing unicode characters (String)" $ do + results <- getUnicodeFacts @String + results `shouldBe` unicodeTest + + it "correctly marshals facts containing unicode characters (Text)" $ do + results <- getUnicodeFacts @T.Text + results `shouldBe` unicodeTest + + it "correctly marshals facts containing unicode characters (lazy Text)" $ do + results <- getUnicodeFacts @TL.Text + results `shouldBe` unicodeTest + +runAddAndGetFacts + :: ( forall {k} f (a :: k). Souffle.Fact (f a) + => Souffle.ContainsInputFact EdgeCases (f a) + => Souffle.ContainsOutputFact EdgeCases (f a) + => Compiled.Submit (f a) + => List (f a) -> IO (List (f a))) + -> Spec +runAddAndGetFacts addAndGetFacts = do + it "correctly marshals empty strings back and forth (Strings)" $ do + facts <- addAndGetFacts @EmptyStrings @String factsAddTest + facts `shouldBe` factsAddTest + + it "correctly marshals empty strings back and forth (Text)" $ do + facts <- addAndGetFacts @EmptyStrings @T.Text factsAddTest + facts `shouldBe` factsAddTest + + it "correctly marshals empty strings back and forth (lazy Text)" $ do + facts <- addAndGetFacts @EmptyStrings @TL.Text factsAddTest + facts `shouldBe` factsAddTest + + it "correctly marshals unicode back and forth (Strings)" $ do + facts <- addAndGetFacts @Unicode @String factsUnicodeTest + facts `shouldBe` factsUnicodeTest + + it "correctly marshals unicode back and forth (Text)" $ do + facts <- addAndGetFacts @Unicode @T.Text factsUnicodeTest + facts `shouldBe` factsUnicodeTest + + it "correctly marshals unicode back and forth (lazy Text)" $ do + facts <- addAndGetFacts @Unicode @TL.Text factsUnicodeTest + facts `shouldBe` factsUnicodeTest + + it "correctly marshals really long strings back and forth (Strings)" $ do + let factsData = [LongStrings longString, LongStrings $ join $ Prelude.replicate 10000 "abc"] + facts <- addAndGetFacts @LongStrings @String factsData + facts `shouldBe` factsData + + it "correctly marshals really long strings back and forth (Text)" $ do + let factsData = [LongStrings longString, LongStrings $ T.pack $ join $ Prelude.replicate 10000 "abc"] + facts <- addAndGetFacts @LongStrings @T.Text factsData + facts `shouldBe` factsData + + it "correctly marshals really long strings back and forth (lazy Text)" $ do + let factsData = [LongStrings longString, LongStrings $ TL.pack $ join $ Prelude.replicate 10000 "abc"] + facts <- addAndGetFacts @LongStrings @TL.Text factsData + facts `shouldBe` factsData + + it "correctly marshals facts with number-like types" $ do + let factsData = + [ NoStrings 42 (-100) 1.5 + , NoStrings 123 (-456) 3.14 + , NoStrings 789 (-789) 1000.123 + , NoStrings 0x12345678 (-1000) 1234.56789 + ] + facts <- addAndGetFacts @NoStrings @Void factsData + facts `shouldBe` factsData + edgeCaseSpecs :: Spec edgeCaseSpecs = describe "edge cases" $ parallel $ do - let longString :: IsString a => a - longString = "long_string_from_DL:...............................................................................................................................................................................................................................................................................................end" - - getFactsI :: forall f a. (Souffle.Fact (f a), Souffle.ContainsOutputFact EdgeCases (f a)) => IO [f a] - getFactsI = Interpreted.runSouffle EdgeCases $ \handle -> do - let prog = fromJust handle - Interpreted.run prog - Interpreted.getFacts prog - getFactsC :: forall f a. (Souffle.Fact (f a), Souffle.ContainsOutputFact EdgeCases (f a)) => IO [f a] - getFactsC = Compiled.runSouffle EdgeCases $ \handle -> do - let prog = fromJust handle - Compiled.run prog - Prelude.reverse <$> Compiled.getFacts prog - - getUnicodeFactsI :: forall a. (IsString a, Eq a, Souffle.Fact (Unicode a), Souffle.ContainsOutputFact EdgeCases (Unicode a)) - => IO ([Unicode a], Maybe (Unicode a), Maybe (Unicode a)) - getUnicodeFactsI = Interpreted.runSouffle EdgeCases $ \handle -> do - let prog = fromJust handle - Interpreted.run prog - (,,) <$> Interpreted.getFacts prog - <*> Interpreted.findFact prog (Unicode "⌀") -- \x2300 iso \x2200 - <*> Interpreted.findFact prog (Unicode "≂") -- \x2242 iso \x2200 - - getUnicodeFactsC :: forall a. (IsString a, Eq a, Souffle.Fact (Unicode a), Souffle.ContainsOutputFact EdgeCases (Unicode a), Compiled.Submit (Unicode a)) - => IO ([Unicode a], Maybe (Unicode a), Maybe (Unicode a)) - getUnicodeFactsC = Compiled.runSouffle EdgeCases $ \handle -> do - let prog = fromJust handle - Compiled.run prog - (,,) <$> (Prelude.reverse <$> Compiled.getFacts prog) - <*> Compiled.findFact prog (Unicode "⌀") -- \x2300 iso \x2200 - <*> Compiled.findFact prog (Unicode "≂") -- \x2242 iso \x2200 - - addAndGetFactsI :: Souffle.Fact (f a) - => Souffle.ContainsInputFact EdgeCases (f a) - => Souffle.ContainsOutputFact EdgeCases (f a) - => [f a] -> IO [f a] - addAndGetFactsI fs = Interpreted.runSouffle EdgeCases $ \handle -> do - let prog = fromJust handle - Interpreted.addFacts prog fs - Interpreted.run prog - Interpreted.getFacts prog - addAndGetFactsC :: Souffle.Fact (f a) - => Souffle.ContainsInputFact EdgeCases (f a) - => Souffle.ContainsOutputFact EdgeCases (f a) - => Compiled.Submit (f a) - => [f a] -> IO [f a] - addAndGetFactsC fs = Compiled.runSouffle EdgeCases $ \handle -> do - let prog = fromJust handle - Compiled.addFacts prog fs - Compiled.run prog - Prelude.reverse <$> Compiled.getFacts prog - - - runTests :: (forall f a. (Souffle.Fact (f a), Souffle.ContainsOutputFact EdgeCases (f a)) => IO [f a]) - -> (forall a. (IsString a, Eq a, Souffle.Fact (Unicode a), Souffle.ContainsOutputFact EdgeCases (Unicode a), Compiled.Submit (Unicode a)) - => IO ([Unicode a], Maybe (Unicode a), Maybe (Unicode a))) - -> (forall f a. Souffle.Fact (f a) - => Souffle.ContainsInputFact EdgeCases (f a) - => Souffle.ContainsOutputFact EdgeCases (f a) - => Compiled.Submit (f a) - => [f a] -> IO [f a]) - -> Spec - runTests getFacts getUnicodeFacts addAndGetFacts = do - it "correctly marshals facts with number-like types" $ do - facts <- getFacts - (facts :: [NoStrings Void]) - `shouldBe` [ NoStrings 42 (-100) 1.5 - , NoStrings 123 (-456) 3.14 - ] - - it "correctly marshals facts with empty Strings" $ do - facts <- getFacts - (facts :: [EmptyStrings String]) - `shouldBe` [ EmptyStrings "" "" 42 - , EmptyStrings "" "abc" 42 - , EmptyStrings "abc" "" 42 - ] - - it "correctly marshals facts with empty Texts" $ do - facts <- getFacts - (facts :: [EmptyStrings T.Text]) - `shouldBe` [ EmptyStrings "" "" 42 - , EmptyStrings "" "abc" 42 - , EmptyStrings "abc" "" 42 - ] - - it "correctly marshals facts with empty lazy Texts" $ do - facts <- getFacts - (facts :: [EmptyStrings TL.Text]) - `shouldBe` [ EmptyStrings "" "" 42 - , EmptyStrings "" "abc" 42 - , EmptyStrings "abc" "" 42 - ] - - it "correctly marshals facts really with long (>255 chars) String" $ do - facts <- getFacts - (facts :: [LongStrings String]) `shouldBe` [ LongStrings longString ] - - it "correctly marshals facts really with long (>255 chars) Text" $ do - facts <- getFacts - (facts :: [LongStrings T.Text]) `shouldBe` [ LongStrings longString ] - - it "correctly marshals facts really with long (>255 chars) lazy Text" $ do - facts <- getFacts - (facts :: [LongStrings TL.Text]) `shouldBe` [ LongStrings longString ] - - it "correctly marshals facts containing unicode characters (String)" $ do - results <- getUnicodeFacts - results `shouldBe` - ( [ Unicode ("∀" :: String), Unicode "∀∀" ] - , Nothing :: Maybe (Unicode String) - , Nothing :: Maybe (Unicode String) - ) - - it "correctly marshals facts containing unicode characters (Text)" $ do - results <- getUnicodeFacts - results `shouldBe` - ( [ Unicode ("∀" :: T.Text), Unicode "∀∀" ] - , Nothing :: Maybe (Unicode T.Text) - , Nothing :: Maybe (Unicode T.Text) - ) - - it "correctly marshals facts containing unicode characters (lazy Text)" $ do - results <- getUnicodeFacts - results `shouldBe` - ( [ Unicode ("∀" :: TL.Text), Unicode "∀∀" ] - , Nothing :: Maybe (Unicode TL.Text) - , Nothing :: Maybe (Unicode TL.Text) - ) - - it "correctly marshals empty strings back and forth (Strings)" $ do - let facts :: [EmptyStrings String] - facts = [EmptyStrings "" "" 1, EmptyStrings "" "" 42, EmptyStrings "" "abc" 2, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 3, EmptyStrings "abc" "" 42] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals empty strings back and forth (Text)" $ do - let facts :: [EmptyStrings T.Text] - facts = [EmptyStrings "" "" 1, EmptyStrings "" "" 42, EmptyStrings "" "abc" 2, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 3, EmptyStrings "abc" "" 42] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals empty strings back and forth (lazy Text)" $ do - let facts :: [EmptyStrings TL.Text] - facts = [EmptyStrings "" "" 1, EmptyStrings "" "" 42, EmptyStrings "" "abc" 2, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 3, EmptyStrings "abc" "" 42] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals unicode back and forth (Strings)" $ do - let facts :: [Unicode String] - facts = [Unicode "∀", Unicode "∀∀", Unicode "≂", Unicode "⌀", Unicode "⌀⌀"] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals unicode back and forth (Text)" $ do - let facts :: [Unicode T.Text] - facts = [Unicode "∀", Unicode "∀∀", Unicode "≂", Unicode "⌀", Unicode "⌀⌀"] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals unicode back and forth (lazy Text)" $ do - let facts :: [Unicode TL.Text] - facts = [Unicode "∀", Unicode "∀∀", Unicode "≂", Unicode "⌀", Unicode "⌀⌀"] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals really long strings back and forth (Strings)" $ do - let facts :: [LongStrings String] - facts = [LongStrings longString, LongStrings $ join $ Prelude.replicate 10000 "abc"] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals really long strings back and forth (Text)" $ do - let facts :: [LongStrings T.Text] - facts = [LongStrings longString, LongStrings $ T.pack $ join $ Prelude.replicate 10000 "abc"] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals really long strings back and forth (lazy Text)" $ do - let facts :: [LongStrings TL.Text] - facts = [LongStrings longString, LongStrings $ TL.pack $ join $ Prelude.replicate 10000 "abc"] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts - - it "correctly marshals facts with number-like types" $ do - let facts :: [NoStrings Void] - facts = [ NoStrings 42 (-100) 1.5 - , NoStrings 123 (-456) 3.14 - , NoStrings 789 (-789) 1000.123 - , NoStrings 0x12345678 (-1000) 1234.56789 - ] - facts' <- addAndGetFacts facts - facts' `shouldBe` facts describe "interpreted mode" $ parallel $ do - runTests getFactsI getUnicodeFactsI addAndGetFactsI + runGetFacts $ Interpreted.runSouffle EdgeCases $ \handle -> do + let prog = fromJust handle + Interpreted.run prog + Interpreted.getFacts prog + + runGetUnicodeFacts $ Interpreted.runSouffle EdgeCases $ \handle -> do + let prog = fromJust handle + Interpreted.run prog + (,,) <$> Interpreted.getFacts prog + <*> Interpreted.findFact prog (Unicode "⌀") -- \x2300 iso \x2200 + <*> Interpreted.findFact prog (Unicode "≂") -- \x2242 iso \x2200 + + runAddAndGetFacts $ \fs -> Interpreted.runSouffle EdgeCases $ \handle -> do + let prog = fromJust handle + Interpreted.addFacts prog fs + Interpreted.run prog + Interpreted.getFacts prog describe "compiled mode" $ parallel $ do - runTests getFactsC getUnicodeFactsC addAndGetFactsC + runGetFacts $ Compiled.runSouffle EdgeCases $ \handle -> do + let prog = fromJust handle + Compiled.run prog + Prelude.reverse <$> Compiled.getFacts prog + + runGetUnicodeFacts $ Compiled.runSouffle EdgeCases $ \handle -> do + let prog = fromJust handle + Compiled.run prog + (,,) <$> (Prelude.reverse <$> Compiled.getFacts prog) + <*> Compiled.findFact prog (Unicode "⌀") -- \x2300 iso \x2200 + <*> Compiled.findFact prog (Unicode "≂") -- \x2242 iso \x2200 + + runAddAndGetFacts $ \fs -> Compiled.runSouffle EdgeCases $ \handle -> do + let prog = fromJust handle + Compiled.addFacts prog fs + Compiled.run prog + Prelude.reverse <$> Compiled.getFacts prog