diff --git a/core/bench/Main.hs b/core/bench/Main.hs index 8da6ec1..fec2cc6 100644 --- a/core/bench/Main.hs +++ b/core/bench/Main.hs @@ -20,11 +20,13 @@ main :: IO () main = defaultMain benchmarks benchmarks :: [Benchmark] -benchmarks = [ bgroup "clique" [clique n | n <- [5, 10, 25, 40]] - , bgroup "line" [line n | n <- [5, 10, 25, 40]] - , bgroup "loop" [loop n | n <- [50, 100, 500, 1000]] - , bgroup "tight" [tight n | n <- [50, 100, 500, 1000]] - , bgroup "parse" [parse n | n <- [50, 100, 500, 1000]] +benchmarks = [ bgroup "clique" [clique n | n <- [5, 10, 25, 40]] + , bgroup "cliqueText" [cliqueText n | n <- [5, 10, 25, 40]] + , bgroup "line" [line n | n <- [5, 10, 25, 40]] + , bgroup "lineText" [lineText n | n <- [5, 10, 25, 40]] + , bgroup "loop" [loop n | n <- [50, 100, 500, 1000]] + , bgroup "tight" [tight n | n <- [50, 100, 500, 1000]] + , bgroup "parse" [parse n | n <- [50, 100, 500, 1000]] ] -- | Generate a complete graph of size @n@ and try to find a path from the first node to the last. @@ -58,6 +60,21 @@ clique n = do let Right cfg = pdpConfigRules mempty path newHandle cfg {maxDepth = 4000} +cliqueText :: Int -> Benchmark +cliqueText n = do + let path = [rls| path(?x, ?y) :- application says edge(?x, ?y). + path(?x, ?z) :- path(?x, ?y), path(?y, ?z). |] + edges = [lit "edge" [val . pack $ show x, val . pack $ show y] + | x <- [1..n] + , y <- [1..n]] + go hdl = bench (show n) $ whnfIO $ do + res <- checkQuery hdl edges "path" [val $ pack "1", val . pack $ show n] + either (error . show) (bool (error "no path found") (pure True)) res + + flip env go $ do + let Right cfg = pdpConfigRules mempty path + newHandle cfg {maxDepth = 4000} + -- | Generates a linear sequence of @n@ facts and tries to find a path from the first node to the -- last. It uses a cons-list shaped @path@ rule. The @application@ assertion looks like this: -- @@ -81,6 +98,20 @@ line n = do let Right cfg = pdpConfigRules mempty path newHandle cfg {maxDepth = 4000} +lineText :: Int -> Benchmark +lineText n = do + let path = [rls| path(?x, ?y) :- application says edge(?x, ?y). + path(?x, ?z) :- application says edge(?x, ?y), path(?y, ?z). |] + edges = [lit "edge" [val . pack $ show x, val . pack $ show y] + | (x, y) <- zip [1..pred n] [2..n]] + go hdl = bench (show n) $ whnfIO $ do + res <- checkQuery hdl edges "path" [val $ pack "1", val . pack $ show n] + either (error . show) (bool (error "no path found") (pure True)) res + + flip env go $ do + let Right cfg = pdpConfigRules mempty path + newHandle cfg {maxDepth = 4000} + -- | Generates a loop of five rules (@e@ implies @d@ implies @c@ implies @b@ implies @a@ implies -- @e@), each of arity 4 (so that the benchmark exercises the unification code), and then runs a -- query with @n@ fuel. diff --git a/core/package.yaml b/core/package.yaml index 74729a6..d687743 100644 --- a/core/package.yaml +++ b/core/package.yaml @@ -10,6 +10,7 @@ library: - deepseq - filepath - hashable + - intern - megaparsec - mtl - qq-literals diff --git a/core/src/Language/Avaleryar/ModeCheck.hs b/core/src/Language/Avaleryar/ModeCheck.hs index 5b22892..db3197f 100644 --- a/core/src/Language/Avaleryar/ModeCheck.hs +++ b/core/src/Language/Avaleryar/ModeCheck.hs @@ -27,7 +27,7 @@ data ModeError | FVModeRestricted RawVar | FVInAssertionPosition RawVar | FVInRuleHead RawVar - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Show) instance Pretty ModeError where pretty (UnboundNativeAssertion assn) = "unbound native assertion: " <> squotes (pretty assn) diff --git a/core/src/Language/Avaleryar/PDP.hs b/core/src/Language/Avaleryar/PDP.hs index 488ba34..3f5a54a 100644 --- a/core/src/Language/Avaleryar/PDP.hs +++ b/core/src/Language/Avaleryar/PDP.hs @@ -50,7 +50,7 @@ data PDPError | VarInQueryResults TextVar | ParseError String | SubmitError SubmitError - deriving (Eq, Ord, Read, Show, Typeable) + deriving (Eq, Ord, Show, Typeable) instance Exception PDPError diff --git a/core/src/Language/Avaleryar/Parser.hs b/core/src/Language/Avaleryar/Parser.hs index ea18ced..a84435a 100644 --- a/core/src/Language/Avaleryar/Parser.hs +++ b/core/src/Language/Avaleryar/Parser.hs @@ -19,6 +19,7 @@ module Language.Avaleryar.Parser import Control.Monad (void) import Data.Bifunctor (first) import Data.Either (partitionEithers) +import qualified Data.Interned as Interned import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -65,9 +66,9 @@ sym = lexeme (T.pack <$> go) "symbol" value :: Parser Value value = I <$> L.signed (pure ()) L.decimal - <|> T <$> stringLiteral - <|> T <$> sym -- unquoted symbols - <|> B <$> (string "#t" *> pure True <|> string "#f" *> pure False) + <|> T <$> fmap Interned.intern stringLiteral + <|> T <$> fmap Interned.intern sym -- unquoted symbols + <|> B <$> (string "#t" *> pure True <|> string "#f" *> pure False) ident :: Parser Text ident = sym "identifer" @@ -183,4 +184,3 @@ qry = qqLiteral queryQQParser 'queryQQParser fct :: QuasiQuoter fct = qqLiteral factQQParser 'factQQParser - diff --git a/core/src/Language/Avaleryar/Semantics.hs b/core/src/Language/Avaleryar/Semantics.hs index 6b1e3b5..1ab4b83 100644 --- a/core/src/Language/Avaleryar/Semantics.hs +++ b/core/src/Language/Avaleryar/Semantics.hs @@ -71,6 +71,8 @@ import Control.Monad.Except import Control.Monad.State import Data.Foldable import qualified Data.HashSet as HashSet +import qualified Data.Interned as Interned +import qualified Data.Interned.Internal.Text as Interned import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -349,10 +351,10 @@ compileQuery' :: String -> Query -> Avaleryar (Lit EVar) compileQuery' assn (Lit (Pred p _) args) = compileQuery assn p args insertRuleAssertion :: Text -> Map Pred (Lit EVar -> Avaleryar ()) -> RulesDb -> RulesDb -insertRuleAssertion assn rules = RulesDb . Map.insert (T assn) rules . unRulesDb +insertRuleAssertion assn rules = RulesDb . Map.insert (toValue assn) rules . unRulesDb retractRuleAssertion :: Text -> RulesDb -> RulesDb -retractRuleAssertion assn = RulesDb . Map.delete (T assn) . unRulesDb +retractRuleAssertion assn = RulesDb . Map.delete (toValue assn) . unRulesDb --------------------- diff --git a/core/src/Language/Avaleryar/Syntax.hs b/core/src/Language/Avaleryar/Syntax.hs index 674e0f5..7778d57 100644 --- a/core/src/Language/Avaleryar/Syntax.hs +++ b/core/src/Language/Avaleryar/Syntax.hs @@ -45,11 +45,13 @@ name of the assertion in which @may\/1@ is defined). In brief: module Language.Avaleryar.Syntax where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData(rnf)) import Data.Char (isSpace) import Data.Function (on) import Data.Functor.Const (Const(..)) import Data.Hashable (Hashable(hashWithSalt)) +import qualified Data.Interned as Interned +import qualified Data.Interned.Internal.Text as Interned import Data.Map (Map) import Data.String import Data.Text (Text) @@ -62,11 +64,15 @@ import Text.PrettyPrint.Leijen.Text data Value = I Int - | T Text + | T Interned.InternedText | B Bool - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) + +instance NFData Value where + rnf (I i) = rnf i + rnf (T t) = rnf (Interned.unintern t) + rnf (B b) = rnf b -instance NFData Value instance Hashable Value instance IsString Value where @@ -75,12 +81,12 @@ instance IsString Value where instance Pretty Value where pretty (I n) = pretty n pretty (B b) = if b then "#t" else "#f" - pretty (T t) = if T.any isSpace t - then pretty (show t) -- want the quotes/escaping - else pretty t -- display as a symbol + pretty (T t) = if T.any isSpace (Interned.unintern t) + then pretty (show $ Interned.unintern t) -- want the quotes/escaping + else pretty (Interned.unintern t) -- display as a symbol -- | A predicate is identified by its name and arity (i.e., the predicate of the literal @foo(bar, ?baz)@ is @foo/2@) -data Pred = Pred Text Int deriving (Eq, Ord, Read, Show, Generic) +data Pred = Pred Text Int deriving (Eq, Ord, Show, Generic) instance NFData Pred instance Hashable Pred @@ -92,7 +98,7 @@ instance Pretty Pred where -- provide a bit of safety by keeping us from crossing various streams (e.g., separating runtime -- unification variables from raw variables straight out of the parser helps avoid a bit of unwanted -- variable capture). -data Term v = Val Value | Var v deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) +data Term v = Val Value | Var v deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) instance NFData v => NFData (Term v) instance Hashable v => Hashable (Term v) @@ -103,7 +109,7 @@ instance Pretty v => Pretty (Term v) where -- | A literal is identified by a 'Pred' and a list of 'Term's, where the arity in the 'Pred' is the -- same as the length of the list of 'Term's in the argument list. -data Lit v = Lit Pred [Term v] deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) +data Lit v = Lit Pred [Term v] deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) instance NFData v => NFData (Lit v) instance Hashable v => Hashable (Lit v) @@ -117,7 +123,7 @@ lit pn as = Lit (Pred pn (length as)) as -- | A reference to an assertion may either statically denote a native assertion or appear as a -- 'Term'. -data ARef v = ARNative Text | ARTerm (Term v) | ARCurrent deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) +data ARef v = ARNative Text | ARTerm (Term v) | ARCurrent deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) instance NFData v => NFData (ARef v) instance Hashable v => Hashable (ARef v) @@ -136,7 +142,7 @@ prettyAssertion assn ps = pretty assn -- When no assertion appears in the concrete syntax, the parser inserts a reference to the assertion -- currently being parsed. data BodyLit v = Says (ARef v) (Lit v) - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) instance NFData v => NFData (BodyLit v) instance Hashable v => Hashable (BodyLit v) @@ -146,7 +152,7 @@ instance Pretty v => Pretty (BodyLit v) where -- | A rule has a head and a body made of 'BodyLit's. data Rule v = Rule (Lit v) [BodyLit v] - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) instance NFData v => NFData (Rule v) instance Hashable v => Hashable (Rule v) @@ -265,8 +271,8 @@ instance Valuable Value where fromValue = Just instance Valuable Text where - toValue = T - fromValue (T a) = Just a + toValue = T . Interned.intern + fromValue (T a) = Just (Interned.unintern a) fromValue _ = Nothing instance Valuable Int where diff --git a/core/src/Language/Avaleryar/Testing.hs b/core/src/Language/Avaleryar/Testing.hs index 3297a0c..e382083 100644 --- a/core/src/Language/Avaleryar/Testing.hs +++ b/core/src/Language/Avaleryar/Testing.hs @@ -53,6 +53,7 @@ module Language.Avaleryar.Testing import Data.Bool (bool) import Data.Foldable (for_, toList) +import qualified Data.Interned as Interned import qualified Data.Map as Map import Data.Text (Text, splitOn) import Data.Void (vacuous) @@ -93,9 +94,9 @@ parseTestCase (Directive (Lit (Pred "test" _) (tn:dbs)) tqs) = do parseTestCase _ = Nothing parseDb :: (Text, Text) -> Directive -> Maybe TestDb -parseDb (alias, assn) (Directive (Lit (Pred "db" _) [Val (T dbn)]) fs) | assn == dbn = +parseDb (alias, assn) (Directive (Lit (Pred "db" _) [Val (T dbn)]) fs) | Interned.intern assn == dbn = Just ([(alias, fmap factToRule fs)], mempty) -parseDb (alias, assn) (Directive (Lit (Pred "native" _) [Val (T dbn)]) fs) | assn == dbn = +parseDb (alias, assn) (Directive (Lit (Pred "native" _) [Val (T dbn)]) fs) | Interned.intern assn == dbn = Just (mempty, mkNativeDb alias $ factsToNative fs) parseDb _ _ = Nothing @@ -207,7 +208,3 @@ runTestFile conf k tf = do case parsed of Left err -> pure (Left err) Right ts -> Right <$> traverse gatherResults ts - - - -