fdilke/pyrites
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactoring (broken test!)

Browse Source
This commit is contained in:
Felix Dilke 2026-01-27 16:41:33 +00:00
parent b982072281
commit 9fc3cc9fa0
2 changed files with 284 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

193
haskell-experiments/src/Datalog/NaiveDatabase.hs
View File

@ -1,69 +1,74 @@
{-# HLINT ignore "Redundant flip" #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant flip" #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Datalog.NaiveDatabase where module Datalog.NaiveDatabase where
import Control.Exception.Base
import Data.List
import Data.Map (Map) import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Set (Set) import Data.Set (Set)
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Text (Text) import Data.Text (Text)
import Datalog.DatalogParser(parseDatalog, Literal(..), Statement(..), Term (..), Head (HeadSingle))
import qualified Data.Map as Map
import Text.Megaparsec (ParseErrorBundle)
import Data.Void import Data.Void
import Control.Exception.Base import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog)
import Data.List import Text.Megaparsec (ParseErrorBundle)
import Data.Maybe
data Value = data Value
ValueInt Int | = ValueInt Int
ValueSymbol String | ValueSymbol String
data NaiveDatabase = NaiveDatabase { data NaiveDatabase = NaiveDatabase
relations :: Map RelationId Relation, { relations :: Map RelationId Relation
constants :: Set Constant , constants :: Set Constant
} }
data RuleElement = -- entry occurring in a head or body relation - constant or variable data RuleElement -- entry occurring in a head or body relation - constant or variable
RuleElementConstant Constant | = RuleElementConstant Constant
RuleElementVariable Text | RuleElementVariable Text
deriving (Show, Eq) deriving (Show, Eq)
data RuleBodyElement = RuleBodyElement { data RuleBodyElement = RuleBodyElement
_subRelationId :: RelationId, { _subRelationId :: RelationId
_ruleElements :: [RuleElement] , _ruleElements :: [RuleElement]
} deriving (Show, Eq) }
deriving (Show, Eq)
data RelationRule = RelationRule { data RelationRule = RelationRule
headVariables :: [Text], { headVariables :: [Text]
bodyElements :: [RuleBodyElement] , bodyElements :: [RuleBodyElement]
} deriving (Show, Eq) }
deriving (Show, Eq)
data Relation = Relation { data Relation = Relation
_name :: RelationId, { _name :: RelationId
_arity :: Int, , _arity :: Int
_tuples :: Set [Constant], , _tuples :: Set [Constant]
_rules :: [RelationRule] , _rules :: [RelationRule]
} deriving (Show, Eq) }
deriving (Show, Eq)
-- Our constants will be the terms of the Datalog grammar - ints/variables/symbols -- Our constants will be the terms of the Datalog grammar - ints/variables/symbols
type Constant = Term type Constant = Term
type RelationId = Text type RelationId = Text
emptyDB :: NaiveDatabase emptyDB :: NaiveDatabase
emptyDB = NaiveDatabase { emptyDB =
relations = Map.empty, NaiveDatabase
constants = Set.empty -- the Herbrand universe { relations = Map.empty
} , constants = Set.empty -- the Herbrand universe
}
withFacts :: [Text] -> NaiveDatabase withFacts :: [Text] -> NaiveDatabase
withFacts facts = withFacts facts =
foldl addFact emptyDB (extractFact <$> facts) where foldl addFact emptyDB (extractFact <$> facts)
extractFact:: Text -> Literal where
extractFact :: Text -> Literal
extractFact factText = extractFact factText =
case (parseDatalog factText) of case (parseDatalog factText) of
Right (Fact fact) -> fact Right (Fact fact) -> fact
@ -71,7 +76,8 @@ withFacts facts =
Left ex -> throw $ CannotParseStatementException factText ex Left ex -> throw $ CannotParseStatementException factText ex
addFact :: NaiveDatabase -> Literal -> NaiveDatabase addFact :: NaiveDatabase -> Literal -> NaiveDatabase
addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) = addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) =
NaiveDatabase newRelationMap newConstantSet where NaiveDatabase newRelationMap newConstantSet
where
newArity = length terms newArity = length terms
newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms) newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms)
newRelationMap = Map.insert relationName newRelation relationMap newRelationMap = Map.insert relationName newRelation relationMap
@ -88,23 +94,23 @@ lookupRelation relationName relationMap newArity tuples =
in Relation relationName newArity newTuples [] in Relation relationName newArity newTuples []
else throw $ BadArityException relationName newArity else throw $ BadArityException relationName newArity
data ConstraintElement = -- entry occurring in a rule body constraint - constant or variable index data ConstraintElement -- entry occurring in a rule body constraint - constant or variable index
ConstraintElementConstant Constant | = ConstraintElementConstant Constant
ConstraintElementIndex Int | ConstraintElementIndex Int
deriving (Show, Eq) deriving (Show, Eq)
data BodyConstraint = BodyConstraint { data BodyConstraint = BodyConstraint
_relation :: Relation, { _relation :: Relation
_elements :: [ConstraintElement] , _elements :: [ConstraintElement]
} }
data RuleContext = RuleContext { data RuleContext = RuleContext
__relation :: Relation, { __relation :: Relation
-- _variableNames :: [Text], , -- _variableNames :: [Text],
_headVariables :: [RuleElement], _headVariables :: [RuleElement]
_bodyConstraints :: [BodyConstraint], , _bodyConstraints :: [BodyConstraint]
_db :: NaiveDatabase , _db :: NaiveDatabase
} }
maybeConstant :: RuleElement -> Maybe Constant maybeConstant :: RuleElement -> Maybe Constant
maybeConstant (RuleElementConstant constant) = Just constant maybeConstant (RuleElementConstant constant) = Just constant
@ -112,8 +118,9 @@ maybeConstant _ = Nothing
withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
withFactsAndRules facts rules = withFactsAndRules facts rules =
foldl addRule (withFacts facts) (extractRule <$> rules) where foldr addRule (withFacts facts) (extractRule <$> rules)
extractRule:: Text -> (Literal, [Literal]) where
extractRule :: Text -> (Literal, [Literal])
extractRule ruleText = extractRule ruleText =
case (parseDatalog ruleText) of case (parseDatalog ruleText) of
Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs) Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs)
@ -121,12 +128,13 @@ withFactsAndRules facts rules =
Left ex -> throw $ CannotParseStatementException ruleText ex Left ex -> throw $ CannotParseStatementException ruleText ex
digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext
digestHead db relation (Literal neg relationName terms) = digestHead db relation (Literal neg relationName terms) =
RuleContext { RuleContext
__relation = relation, { __relation = relation
_headVariables = variables', , _headVariables = variables'
_bodyConstraints = [], , _bodyConstraints = []
_db = NaiveDatabase relationMap' constants' , _db = NaiveDatabase relationMap' constants'
} where }
where
relationMap :: Map RelationId Relation = relations db relationMap :: Map RelationId Relation = relations db
relationMap' = Map.insert relationName relation relationMap relationMap' = Map.insert relationName relation relationMap
extraVariables = toElement <$> terms extraVariables = toElement <$> terms
@ -135,12 +143,13 @@ withFactsAndRules facts rules =
constants' = Set.union (constants db) $ Set.fromList extraConstants constants' = Set.union (constants db) $ Set.fromList extraConstants
digestBody :: RuleContext -> Literal -> RuleContext digestBody :: RuleContext -> Literal -> RuleContext
digestBody context (Literal neg subRelationName terms) = digestBody context (Literal neg subRelationName terms) =
RuleContext { RuleContext
__relation = relation, { __relation = relation
_headVariables = variables', , _headVariables = variables'
_bodyConstraints = constraints', , _bodyConstraints = constraints'
_db = NaiveDatabase relationMap' constants' , _db = NaiveDatabase relationMap' constants'
} where }
where
relation = __relation context relation = __relation context
newArity = length terms newArity = length terms
subRelation = lookupRelation subRelationName relationMap newArity Set.empty subRelation = lookupRelation subRelationName relationMap newArity Set.empty
@ -161,9 +170,10 @@ withFactsAndRules facts rules =
toConstraint :: Term -> ConstraintElement toConstraint :: Term -> ConstraintElement
toConstraint (Var name) = ConstraintElementIndex (varIndex name) toConstraint (Var name) = ConstraintElementIndex (varIndex name)
toConstraint constant = ConstraintElementConstant constant toConstraint constant = ConstraintElementConstant constant
addRule :: NaiveDatabase -> (Literal, [Literal]) -> NaiveDatabase addRule :: (Literal, [Literal]) -> NaiveDatabase ->NaiveDatabase
addRule db (ruleHead, body) = addRule (ruleHead, body) db =
NaiveDatabase newRelationMap constants' where NaiveDatabase newRelationMap constants'
where
relationName = predName ruleHead relationName = predName ruleHead
terms = arguments ruleHead terms = arguments ruleHead
newArity = length terms newArity = length terms
@ -176,24 +186,27 @@ withFactsAndRules facts rules =
extractVarName :: RuleElement -> Maybe Text extractVarName :: RuleElement -> Maybe Text
extractVarName (RuleElementVariable varName) = Just varName extractVarName (RuleElementVariable varName) = Just varName
extractVarName (RuleElementConstant constant) = Nothing extractVarName (RuleElementConstant constant) = Nothing
newRule = RelationRule { newRule =
headVariables = catMaybes $ extractVarName <$> variables', RelationRule
bodyElements = fromBodyConstraint <$> (_bodyConstraints context'') { headVariables = catMaybes $ extractVarName <$> variables'
} where , bodyElements = fromBodyConstraint <$> (_bodyConstraints context'')
}
where
fromBodyConstraint :: BodyConstraint -> RuleBodyElement fromBodyConstraint :: BodyConstraint -> RuleBodyElement
fromBodyConstraint (BodyConstraint subRelation elements) = fromBodyConstraint (BodyConstraint subRelation elements) =
RuleBodyElement { RuleBodyElement
_subRelationId = _name subRelation, { _subRelationId = _name subRelation
_ruleElements = toRuleElement <$> elements , _ruleElements = toRuleElement <$> elements
} }
toRuleElement :: ConstraintElement -> RuleElement toRuleElement :: ConstraintElement -> RuleElement
toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
toRuleElement (ConstraintElementIndex index) = variables' !! index toRuleElement (ConstraintElementIndex index) = variables' !! index
relation' = Relation { relation' =
_name = _name relation, Relation
_arity = newArity, { _name = _name relation
_tuples = _tuples relation, , _arity = newArity
_rules = (_rules relation) ++ [newRule] , _tuples = _tuples relation
, _rules = (_rules relation) ++ [newRule]
} }
newRelationMap = Map.insert relationName relation' relationMap newRelationMap = Map.insert relationName relation' relationMap
constants' = constants db' constants' = constants db'
@ -209,13 +222,13 @@ query db qText =
Left ex -> throw $ CannotParseStatementException qText ex Left ex -> throw $ CannotParseStatementException qText ex
data NaiveDatabaseException data NaiveDatabaseException
= CannotParseStatementException Text (ParseErrorBundle Text Void) | = CannotParseStatementException Text (ParseErrorBundle Text Void)
NonFactException Text Statement | | NonFactException Text Statement
NonRuleException Text Statement | | NonRuleException Text Statement
NonQueryException Text Statement | | NonQueryException Text Statement
BadArityException Text Int | | BadArityException Text Int
VariableLookupException Text [RuleElement] | | VariableLookupException Text [RuleElement]
UnexpectedConstantException Constant | UnexpectedConstantException Constant
deriving (Show) deriving (Show)
instance Exception NaiveDatabaseException instance Exception NaiveDatabaseException

157
haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs
View File

@ -1,106 +1,125 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# HLINT ignore "Use const" #-} {-# HLINT ignore "Use const" #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-} {-# HLINT ignore "Unused LANGUAGE pragma" #-}
{-# HLINT ignore "Avoid lambda" #-} {-# HLINT ignore "Avoid lambda" #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ImportQualifiedPost #-}
module Test.Datalog.NaiveDatabaseSpec where module Test.Datalog.NaiveDatabaseSpec where
import Test.Hspec import Data.Map qualified as Map
import Datalog.NaiveDatabase
import qualified Datalog.NaiveDatabase as NaiveDatabase
import Data.Set qualified as Set import Data.Set qualified as Set
import Datalog.DatalogParser import Datalog.DatalogParser
import qualified Data.Map as Map import Datalog.NaiveDatabase
import Datalog.NaiveDatabase qualified as NaiveDatabase
import Test.Hspec
spec :: Spec spec :: Spec
spec = do spec = do
describe "NaiveDatabase operations" $ do describe "NaiveDatabase operations" do
it "can ingest facts into relations & a universe" $ do it "can ingest facts into relations & a universe" $ do
let db = NaiveDatabase.withFacts let db =
NaiveDatabase.withFacts
[ "parent(\"alice\", \"bob\")." [ "parent(\"alice\", \"bob\")."
, "parent(\"bob\", \"carol\")." ] , "parent(\"bob\", \"carol\")."
constants db `shouldBe`
(Set.fromList $ Sym <$> ["alice", "bob", "carol"])
relations db `shouldBe`
Map.fromList [
("parent",
Relation "parent" 2 (Set.fromList (map (Sym <$>) [["alice", "bob"], ["bob", "carol"]])) [] )
] ]
it "can ingest facts and rules" $ do constants db
let db = NaiveDatabase.withFactsAndRules `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])
relations db
`shouldBe` Map.fromList
[
( "parent"
, Relation "parent" 2 (Set.fromList $ map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]) []
)
]
it "can ingest facts and rules" do
let db =
NaiveDatabase.withFactsAndRules
[ "parent(\"alice\", \"bob\")." [ "parent(\"alice\", \"bob\")."
, "parent(\"bob\", \"carol\")." ] , "parent(\"bob\", \"carol\")."
]
[ "ancestor(X,Y) :- parent(X,Y)." [ "ancestor(X,Y) :- parent(X,Y)."
, "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)." ] , "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."
constants db `shouldBe`
(Set.fromList $ Sym <$> ["alice", "bob", "carol"])
let parentRelation = Relation {
_name = "parent",
_arity = 2,
_tuples = Set.fromList $
map (Sym <$>) [["alice", "bob"], ["bob", "carol"]],
_rules = []
}
let ancestorRule = RelationRule {
headVariables = [ "X", "Y", "Z" ],
bodyElements = [
RuleBodyElement {
_subRelationId = "parent",
_ruleElements = [
RuleElementVariable "X", RuleElementVariable "Z"
] ]
}, parentRelation =
RuleBodyElement { Relation
_subRelationId = "ancestor", { _name = "parent"
_ruleElements = [ , _arity = 2
RuleElementVariable "Z",RuleElementVariable "Y" , _tuples =
Set.fromList $
map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]
, _rules = []
}
ancestorRule =
RelationRule
{ headVariables = ["X", "Y", "Z"]
, bodyElements =
[ RuleBodyElement
{ _subRelationId = "parent"
, _ruleElements =
[ RuleElementVariable "X"
, RuleElementVariable "Z"
]
}
, RuleBodyElement
{ _subRelationId = "ancestor"
, _ruleElements =
[ RuleElementVariable "Z"
, RuleElementVariable "Y"
] ]
} }
] ]
} }
let ancestorRelation = Relation { ancestorRelation =
_arity = 2, Relation
_name = "ancestor", { _arity = 2
_tuples = Set.empty, , _name = "ancestor"
_rules = [ ancestorRule ] , _tuples = Set.empty
, _rules = [ancestorRule]
} }
relations db `shouldBe` constants db
Map.fromList [ `shouldBe` (Set.fromList $ Sym <$> ["alice", "bob", "carol"])
("ancestor", ancestorRelation), relations db
("parent", parentRelation ) `shouldBe` Map.fromList
[ ("ancestor", ancestorRelation)
, ("parent", parentRelation)
] ]
it "can ingest facts and rules with constants" $ do it "can ingest facts and rules with constants" do
let db = NaiveDatabase.withFactsAndRules let db =
NaiveDatabase.withFactsAndRules
[] []
[ "ancestor(X,\"patriarch\") :- ." ] ["ancestor(X,\"patriarch\") :- ."]
let ancestorRule = RelationRule { ancestorRule =
headVariables = [ "X" ], RelationRule
bodyElements = [] { headVariables = ["X"]
, bodyElements = []
} }
let ancestorRelation = Relation { ancestorRelation =
_arity = 2, Relation
_name = "ancestor", { _arity = 2
_tuples = Set.empty, , _name = "ancestor"
_rules = [ ancestorRule ] , _tuples = Set.empty
, _rules = [ancestorRule]
} }
relations db `shouldBe` relations db
Map.fromList [ `shouldBe` Map.fromList
("ancestor", ancestorRelation) [ ("ancestor", ancestorRelation)
] ]
constants db `shouldBe` constants db
(Set.fromList $ Sym <$> ["patriarch"]) `shouldBe` (Set.fromList $ Sym <$> ["patriarch"])
it "can do basic queries" $ do it "can do basic queries" do
let db = NaiveDatabase.withFacts let db =
NaiveDatabase.withFacts
[ "parent(\"alice\", \"bob\")." [ "parent(\"alice\", \"bob\")."
, "parent(\"bob\", \"carol\")." ] , "parent(\"bob\", \"carol\")."
]
query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob' query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'