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

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

@ -1,110 +1,116 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant flip" #-} {-# HLINT ignore "Redundant flip" #-}
{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
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 factText = extractFact :: Text -> Literal
case (parseDatalog factText) of extractFact factText =
Right (Fact fact) -> fact case (parseDatalog factText) of
Right otherStatement -> throw $ NonFactException factText otherStatement Right (Fact fact) -> fact
Left ex -> throw $ CannotParseStatementException factText ex Right otherStatement -> throw $ NonFactException factText otherStatement
addFact :: NaiveDatabase -> Literal -> NaiveDatabase Left ex -> throw $ CannotParseStatementException factText ex
addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) = addFact :: NaiveDatabase -> Literal -> NaiveDatabase
NaiveDatabase newRelationMap newConstantSet where addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) =
newArity = length terms NaiveDatabase newRelationMap newConstantSet
newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms) where
newRelationMap = Map.insert relationName newRelation relationMap newArity = length terms
newConstantSet = Set.union constantSet $ Set.fromList terms newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms)
newRelationMap = Map.insert relationName newRelation relationMap
newConstantSet = Set.union constantSet $ Set.fromList terms
lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation
lookupRelation relationName relationMap newArity tuples = lookupRelation relationName relationMap newArity tuples =
case Map.lookup relationName relationMap of case Map.lookup relationName relationMap of
Nothing -> Relation relationName newArity tuples [] Nothing -> Relation relationName newArity tuples []
Just relation -> Just relation ->
if (_arity relation == newArity) if (_arity relation == newArity)
then then
let newTuples = Set.union tuples $ _tuples relation let newTuples = Set.union tuples $ _tuples relation
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,94 +118,101 @@ 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 ruleText = extractRule :: Text -> (Literal, [Literal])
case (parseDatalog ruleText) of extractRule ruleText =
Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs) case (parseDatalog ruleText) of
Right otherStatement -> throw $ NonRuleException ruleText otherStatement Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs)
Left ex -> throw $ CannotParseStatementException ruleText ex Right otherStatement -> throw $ NonRuleException ruleText otherStatement
digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext Left ex -> throw $ CannotParseStatementException ruleText ex
digestHead db relation (Literal neg relationName terms) = digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext
RuleContext { digestHead db relation (Literal neg relationName terms) =
__relation = relation, RuleContext
_headVariables = variables', { __relation = relation
_bodyConstraints = [], , _headVariables = variables'
_db = NaiveDatabase relationMap' constants' , _bodyConstraints = []
} where , _db = NaiveDatabase relationMap' constants'
relationMap :: Map RelationId Relation = relations db }
relationMap' = Map.insert relationName relation relationMap where
extraVariables = toElement <$> terms relationMap :: Map RelationId Relation = relations db
variables' = nub extraVariables relationMap' = Map.insert relationName relation relationMap
extraConstants = catMaybes $ maybeConstant <$> variables' extraVariables = toElement <$> terms
constants' = Set.union (constants db) $ Set.fromList extraConstants variables' = nub extraVariables
digestBody :: RuleContext -> Literal -> RuleContext extraConstants = catMaybes $ maybeConstant <$> variables'
digestBody context (Literal neg subRelationName terms) = constants' = Set.union (constants db) $ Set.fromList extraConstants
RuleContext { digestBody :: RuleContext -> Literal -> RuleContext
__relation = relation, digestBody context (Literal neg subRelationName terms) =
_headVariables = variables', RuleContext
_bodyConstraints = constraints', { __relation = relation
_db = NaiveDatabase relationMap' constants' , _headVariables = variables'
} where , _bodyConstraints = constraints'
relation = __relation context , _db = NaiveDatabase relationMap' constants'
newArity = length terms }
subRelation = lookupRelation subRelationName relationMap newArity Set.empty where
relationMap :: Map RelationId Relation = relations (_db context) relation = __relation context
relationMap' = Map.insert subRelationName subRelation relationMap newArity = length terms
extraVariables = toElement <$> terms subRelation = lookupRelation subRelationName relationMap newArity Set.empty
extraConstants = catMaybes $ maybeConstant <$> extraVariables relationMap :: Map RelationId Relation = relations (_db context)
variables' = nub $ _headVariables context ++ extraVariables relationMap' = Map.insert subRelationName subRelation relationMap
constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants extraVariables = toElement <$> terms
constraints = _bodyConstraints context extraConstants = catMaybes $ maybeConstant <$> extraVariables
newConstraint = BodyConstraint subRelation (toConstraint <$> terms) variables' = nub $ _headVariables context ++ extraVariables
constraints' = constraints ++ [newConstraint] constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants
varIndex :: Text -> Int constraints = _bodyConstraints context
varIndex name = newConstraint = BodyConstraint subRelation (toConstraint <$> terms)
case elemIndex (RuleElementVariable name) variables' of constraints' = constraints ++ [newConstraint]
Just index -> index varIndex :: Text -> Int
Nothing -> throw $ VariableLookupException name variables' varIndex name =
toConstraint :: Term -> ConstraintElement case elemIndex (RuleElementVariable name) variables' of
toConstraint (Var name) = ConstraintElementIndex (varIndex name) Just index -> index
toConstraint constant = ConstraintElementConstant constant Nothing -> throw $ VariableLookupException name variables'
addRule :: NaiveDatabase -> (Literal, [Literal]) -> NaiveDatabase toConstraint :: Term -> ConstraintElement
addRule db (ruleHead, body) = toConstraint (Var name) = ConstraintElementIndex (varIndex name)
NaiveDatabase newRelationMap constants' where toConstraint constant = ConstraintElementConstant constant
relationName = predName ruleHead addRule :: (Literal, [Literal]) -> NaiveDatabase ->NaiveDatabase
terms = arguments ruleHead addRule (ruleHead, body) db =
newArity = length terms NaiveDatabase newRelationMap constants'
relation = lookupRelation relationName (relations db) newArity Set.empty where
context' = digestHead db relation ruleHead relationName = predName ruleHead
context'' = foldl digestBody context' body terms = arguments ruleHead
db' = _db context'' newArity = length terms
relationMap = relations db' relation = lookupRelation relationName (relations db) newArity Set.empty
variables' = _headVariables context'' context' = digestHead db relation ruleHead
extractVarName :: RuleElement -> Maybe Text context'' = foldl digestBody context' body
extractVarName (RuleElementVariable varName) = Just varName db' = _db context''
extractVarName (RuleElementConstant constant) = Nothing relationMap = relations db'
newRule = RelationRule { variables' = _headVariables context''
headVariables = catMaybes $ extractVarName <$> variables', extractVarName :: RuleElement -> Maybe Text
bodyElements = fromBodyConstraint <$> (_bodyConstraints context'') extractVarName (RuleElementVariable varName) = Just varName
} where extractVarName (RuleElementConstant constant) = Nothing
fromBodyConstraint :: BodyConstraint -> RuleBodyElement newRule =
fromBodyConstraint (BodyConstraint subRelation elements) = RelationRule
RuleBodyElement { { headVariables = catMaybes $ extractVarName <$> variables'
_subRelationId = _name subRelation, , bodyElements = fromBodyConstraint <$> (_bodyConstraints context'')
_ruleElements = toRuleElement <$> elements
}
toRuleElement :: ConstraintElement -> RuleElement
toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
toRuleElement (ConstraintElementIndex index) = variables' !! index
relation' = Relation {
_name = _name relation,
_arity = newArity,
_tuples = _tuples relation,
_rules = (_rules relation) ++ [newRule]
} }
newRelationMap = Map.insert relationName relation' relationMap where
constants' = constants db' fromBodyConstraint :: BodyConstraint -> RuleBodyElement
toElement :: Term -> RuleElement fromBodyConstraint (BodyConstraint subRelation elements) =
toElement (Var name) = RuleElementVariable name RuleBodyElement
toElement constant = RuleElementConstant constant { _subRelationId = _name subRelation
, _ruleElements = toRuleElement <$> elements
}
toRuleElement :: ConstraintElement -> RuleElement
toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
toRuleElement (ConstraintElementIndex index) = variables' !! index
relation' =
Relation
{ _name = _name relation
, _arity = newArity
, _tuples = _tuples relation
, _rules = (_rules relation) ++ [newRule]
}
newRelationMap = Map.insert relationName relation' relationMap
constants' = constants db'
toElement :: Term -> RuleElement
toElement (Var name) = RuleElementVariable name
toElement constant = RuleElementConstant constant
query :: NaiveDatabase -> Text -> Text query :: NaiveDatabase -> Text -> Text
query db qText = query db qText =
@ -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

187
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 =
[ "parent(\"alice\", \"bob\")." NaiveDatabase.withFacts
, "parent(\"bob\", \"carol\")." ] [ "parent(\"alice\", \"bob\")."
constants db `shouldBe` , "parent(\"bob\", \"carol\")."
(Set.fromList $ Sym <$> ["alice", "bob", "carol"]) ]
relations db `shouldBe` constants db
Map.fromList [ `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])
("parent", relations db
Relation "parent" 2 (Set.fromList (map (Sym <$>) [["alice", "bob"], ["bob", "carol"]])) [] ) `shouldBe` Map.fromList
] [
it "can ingest facts and rules" $ do ( "parent"
let db = NaiveDatabase.withFactsAndRules , Relation "parent" 2 (Set.fromList $ map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]) []
[ "parent(\"alice\", \"bob\")." )
, "parent(\"bob\", \"carol\")." ] ]
[ "ancestor(X,Y) :- parent(X,Y)." it "can ingest facts and rules" do
, "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)." ] let db =
constants db `shouldBe` NaiveDatabase.withFactsAndRules
(Set.fromList $ Sym <$> ["alice", "bob", "carol"]) [ "parent(\"alice\", \"bob\")."
let parentRelation = Relation { , "parent(\"bob\", \"carol\")."
_name = "parent", ]
_arity = 2, [ "ancestor(X,Y) :- parent(X,Y)."
_tuples = Set.fromList $ , "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."
map (Sym <$>) [["alice", "bob"], ["bob", "carol"]], ]
_rules = [] parentRelation =
} Relation
let ancestorRule = RelationRule { { _name = "parent"
headVariables = [ "X", "Y", "Z" ], , _arity = 2
bodyElements = [ , _tuples =
RuleBodyElement { Set.fromList $
_subRelationId = "parent", map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]
_ruleElements = [ , _rules = []
RuleElementVariable "X", RuleElementVariable "Z"
]
},
RuleBodyElement {
_subRelationId = "ancestor",
_ruleElements = [
RuleElementVariable "Z",RuleElementVariable "Y"
]
} }
] ancestorRule =
} RelationRule
let ancestorRelation = Relation { { headVariables = ["X", "Y", "Z"]
_arity = 2, , bodyElements =
_name = "ancestor", [ RuleBodyElement
_tuples = Set.empty, { _subRelationId = "parent"
_rules = [ ancestorRule ] , _ruleElements =
} [ RuleElementVariable "X"
relations db `shouldBe` , RuleElementVariable "Z"
Map.fromList [ ]
("ancestor", ancestorRelation), }
("parent", parentRelation ) , RuleBodyElement
] { _subRelationId = "ancestor"
, _ruleElements =
[ RuleElementVariable "Z"
, RuleElementVariable "Y"
]
}
]
}
ancestorRelation =
Relation
{ _arity = 2
, _name = "ancestor"
, _tuples = Set.empty
, _rules = [ancestorRule]
}
constants db
`shouldBe` (Set.fromList $ Sym <$> ["alice", "bob", "carol"])
relations db
`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\") :- ." ] []
let ancestorRule = RelationRule { ["ancestor(X,\"patriarch\") :- ."]
headVariables = [ "X" ], ancestorRule =
bodyElements = [] RelationRule
} { headVariables = ["X"]
let ancestorRelation = Relation { , bodyElements = []
_arity = 2, }
_name = "ancestor", ancestorRelation =
_tuples = Set.empty, Relation
_rules = [ ancestorRule ] { _arity = 2
} , _name = "ancestor"
relations db `shouldBe` , _tuples = Set.empty
Map.fromList [ , _rules = [ancestorRule]
("ancestor", ancestorRelation) }
] relations db
`shouldBe` Map.fromList
[ ("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 =
[ "parent(\"alice\", \"bob\")." NaiveDatabase.withFacts
, "parent(\"bob\", \"carol\")." ] [ "parent(\"alice\", \"bob\")."
, "parent(\"bob\", \"carol\")."
]
query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob' query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'