refactoring (broken test!)
This commit is contained in:
parent
b982072281
commit
9fc3cc9fa0
@ -1,69 +1,74 @@
|
||||
{-# HLINT ignore "Redundant flip" #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Redundant flip" #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Datalog.NaiveDatabase where
|
||||
|
||||
import Control.Exception.Base
|
||||
import Data.List
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as Set
|
||||
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 Control.Exception.Base
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog)
|
||||
import Text.Megaparsec (ParseErrorBundle)
|
||||
|
||||
data Value =
|
||||
ValueInt Int |
|
||||
ValueSymbol String
|
||||
data Value
|
||||
= ValueInt Int
|
||||
| ValueSymbol String
|
||||
|
||||
data NaiveDatabase = NaiveDatabase {
|
||||
relations :: Map RelationId Relation,
|
||||
constants :: Set Constant
|
||||
}
|
||||
data NaiveDatabase = NaiveDatabase
|
||||
{ relations :: Map RelationId Relation
|
||||
, constants :: Set Constant
|
||||
}
|
||||
|
||||
data RuleElement = -- entry occurring in a head or body relation - constant or variable
|
||||
RuleElementConstant Constant |
|
||||
RuleElementVariable Text
|
||||
data RuleElement -- entry occurring in a head or body relation - constant or variable
|
||||
= RuleElementConstant Constant
|
||||
| RuleElementVariable Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
data RuleBodyElement = RuleBodyElement {
|
||||
_subRelationId :: RelationId,
|
||||
_ruleElements :: [RuleElement]
|
||||
} deriving (Show, Eq)
|
||||
data RuleBodyElement = RuleBodyElement
|
||||
{ _subRelationId :: RelationId
|
||||
, _ruleElements :: [RuleElement]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data RelationRule = RelationRule {
|
||||
headVariables :: [Text],
|
||||
bodyElements :: [RuleBodyElement]
|
||||
} deriving (Show, Eq)
|
||||
data RelationRule = RelationRule
|
||||
{ headVariables :: [Text]
|
||||
, bodyElements :: [RuleBodyElement]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Relation = Relation {
|
||||
_name :: RelationId,
|
||||
_arity :: Int,
|
||||
_tuples :: Set [Constant],
|
||||
_rules :: [RelationRule]
|
||||
} deriving (Show, Eq)
|
||||
data Relation = Relation
|
||||
{ _name :: RelationId
|
||||
, _arity :: Int
|
||||
, _tuples :: Set [Constant]
|
||||
, _rules :: [RelationRule]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- Our constants will be the terms of the Datalog grammar - ints/variables/symbols
|
||||
type Constant = Term
|
||||
type RelationId = Text
|
||||
|
||||
emptyDB :: NaiveDatabase
|
||||
emptyDB = NaiveDatabase {
|
||||
relations = Map.empty,
|
||||
constants = Set.empty -- the Herbrand universe
|
||||
}
|
||||
emptyDB =
|
||||
NaiveDatabase
|
||||
{ relations = Map.empty
|
||||
, constants = Set.empty -- the Herbrand universe
|
||||
}
|
||||
|
||||
withFacts :: [Text] -> NaiveDatabase
|
||||
withFacts facts =
|
||||
foldl addFact emptyDB (extractFact <$> facts) where
|
||||
extractFact:: Text -> Literal
|
||||
foldl addFact emptyDB (extractFact <$> facts)
|
||||
where
|
||||
extractFact :: Text -> Literal
|
||||
extractFact factText =
|
||||
case (parseDatalog factText) of
|
||||
Right (Fact fact) -> fact
|
||||
@ -71,7 +76,8 @@ withFacts facts =
|
||||
Left ex -> throw $ CannotParseStatementException factText ex
|
||||
addFact :: NaiveDatabase -> Literal -> NaiveDatabase
|
||||
addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) =
|
||||
NaiveDatabase newRelationMap newConstantSet where
|
||||
NaiveDatabase newRelationMap newConstantSet
|
||||
where
|
||||
newArity = length terms
|
||||
newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms)
|
||||
newRelationMap = Map.insert relationName newRelation relationMap
|
||||
@ -88,23 +94,23 @@ lookupRelation relationName relationMap newArity tuples =
|
||||
in Relation relationName newArity newTuples []
|
||||
else throw $ BadArityException relationName newArity
|
||||
|
||||
data ConstraintElement = -- entry occurring in a rule body constraint - constant or variable index
|
||||
ConstraintElementConstant Constant |
|
||||
ConstraintElementIndex Int
|
||||
data ConstraintElement -- entry occurring in a rule body constraint - constant or variable index
|
||||
= ConstraintElementConstant Constant
|
||||
| ConstraintElementIndex Int
|
||||
deriving (Show, Eq)
|
||||
|
||||
data BodyConstraint = BodyConstraint {
|
||||
_relation :: Relation,
|
||||
_elements :: [ConstraintElement]
|
||||
}
|
||||
data BodyConstraint = BodyConstraint
|
||||
{ _relation :: Relation
|
||||
, _elements :: [ConstraintElement]
|
||||
}
|
||||
|
||||
data RuleContext = RuleContext {
|
||||
__relation :: Relation,
|
||||
-- _variableNames :: [Text],
|
||||
_headVariables :: [RuleElement],
|
||||
_bodyConstraints :: [BodyConstraint],
|
||||
_db :: NaiveDatabase
|
||||
}
|
||||
data RuleContext = RuleContext
|
||||
{ __relation :: Relation
|
||||
, -- _variableNames :: [Text],
|
||||
_headVariables :: [RuleElement]
|
||||
, _bodyConstraints :: [BodyConstraint]
|
||||
, _db :: NaiveDatabase
|
||||
}
|
||||
|
||||
maybeConstant :: RuleElement -> Maybe Constant
|
||||
maybeConstant (RuleElementConstant constant) = Just constant
|
||||
@ -112,8 +118,9 @@ maybeConstant _ = Nothing
|
||||
|
||||
withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
|
||||
withFactsAndRules facts rules =
|
||||
foldl addRule (withFacts facts) (extractRule <$> rules) where
|
||||
extractRule:: Text -> (Literal, [Literal])
|
||||
foldr addRule (withFacts facts) (extractRule <$> rules)
|
||||
where
|
||||
extractRule :: Text -> (Literal, [Literal])
|
||||
extractRule ruleText =
|
||||
case (parseDatalog ruleText) of
|
||||
Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs)
|
||||
@ -121,12 +128,13 @@ withFactsAndRules facts rules =
|
||||
Left ex -> throw $ CannotParseStatementException ruleText ex
|
||||
digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext
|
||||
digestHead db relation (Literal neg relationName terms) =
|
||||
RuleContext {
|
||||
__relation = relation,
|
||||
_headVariables = variables',
|
||||
_bodyConstraints = [],
|
||||
_db = NaiveDatabase relationMap' constants'
|
||||
} where
|
||||
RuleContext
|
||||
{ __relation = relation
|
||||
, _headVariables = variables'
|
||||
, _bodyConstraints = []
|
||||
, _db = NaiveDatabase relationMap' constants'
|
||||
}
|
||||
where
|
||||
relationMap :: Map RelationId Relation = relations db
|
||||
relationMap' = Map.insert relationName relation relationMap
|
||||
extraVariables = toElement <$> terms
|
||||
@ -135,12 +143,13 @@ withFactsAndRules facts rules =
|
||||
constants' = Set.union (constants db) $ Set.fromList extraConstants
|
||||
digestBody :: RuleContext -> Literal -> RuleContext
|
||||
digestBody context (Literal neg subRelationName terms) =
|
||||
RuleContext {
|
||||
__relation = relation,
|
||||
_headVariables = variables',
|
||||
_bodyConstraints = constraints',
|
||||
_db = NaiveDatabase relationMap' constants'
|
||||
} where
|
||||
RuleContext
|
||||
{ __relation = relation
|
||||
, _headVariables = variables'
|
||||
, _bodyConstraints = constraints'
|
||||
, _db = NaiveDatabase relationMap' constants'
|
||||
}
|
||||
where
|
||||
relation = __relation context
|
||||
newArity = length terms
|
||||
subRelation = lookupRelation subRelationName relationMap newArity Set.empty
|
||||
@ -161,9 +170,10 @@ withFactsAndRules facts rules =
|
||||
toConstraint :: Term -> ConstraintElement
|
||||
toConstraint (Var name) = ConstraintElementIndex (varIndex name)
|
||||
toConstraint constant = ConstraintElementConstant constant
|
||||
addRule :: NaiveDatabase -> (Literal, [Literal]) -> NaiveDatabase
|
||||
addRule db (ruleHead, body) =
|
||||
NaiveDatabase newRelationMap constants' where
|
||||
addRule :: (Literal, [Literal]) -> NaiveDatabase ->NaiveDatabase
|
||||
addRule (ruleHead, body) db =
|
||||
NaiveDatabase newRelationMap constants'
|
||||
where
|
||||
relationName = predName ruleHead
|
||||
terms = arguments ruleHead
|
||||
newArity = length terms
|
||||
@ -176,24 +186,27 @@ withFactsAndRules facts rules =
|
||||
extractVarName :: RuleElement -> Maybe Text
|
||||
extractVarName (RuleElementVariable varName) = Just varName
|
||||
extractVarName (RuleElementConstant constant) = Nothing
|
||||
newRule = RelationRule {
|
||||
headVariables = catMaybes $ extractVarName <$> variables',
|
||||
bodyElements = fromBodyConstraint <$> (_bodyConstraints context'')
|
||||
} where
|
||||
newRule =
|
||||
RelationRule
|
||||
{ headVariables = catMaybes $ extractVarName <$> variables'
|
||||
, bodyElements = fromBodyConstraint <$> (_bodyConstraints context'')
|
||||
}
|
||||
where
|
||||
fromBodyConstraint :: BodyConstraint -> RuleBodyElement
|
||||
fromBodyConstraint (BodyConstraint subRelation elements) =
|
||||
RuleBodyElement {
|
||||
_subRelationId = _name subRelation,
|
||||
_ruleElements = toRuleElement <$> elements
|
||||
RuleBodyElement
|
||||
{ _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]
|
||||
relation' =
|
||||
Relation
|
||||
{ _name = _name relation
|
||||
, _arity = newArity
|
||||
, _tuples = _tuples relation
|
||||
, _rules = (_rules relation) ++ [newRule]
|
||||
}
|
||||
newRelationMap = Map.insert relationName relation' relationMap
|
||||
constants' = constants db'
|
||||
@ -209,13 +222,13 @@ query db qText =
|
||||
Left ex -> throw $ CannotParseStatementException qText ex
|
||||
|
||||
data NaiveDatabaseException
|
||||
= CannotParseStatementException Text (ParseErrorBundle Text Void) |
|
||||
NonFactException Text Statement |
|
||||
NonRuleException Text Statement |
|
||||
NonQueryException Text Statement |
|
||||
BadArityException Text Int |
|
||||
VariableLookupException Text [RuleElement] |
|
||||
UnexpectedConstantException Constant
|
||||
= CannotParseStatementException Text (ParseErrorBundle Text Void)
|
||||
| NonFactException Text Statement
|
||||
| NonRuleException Text Statement
|
||||
| NonQueryException Text Statement
|
||||
| BadArityException Text Int
|
||||
| VariableLookupException Text [RuleElement]
|
||||
| UnexpectedConstantException Constant
|
||||
deriving (Show)
|
||||
|
||||
instance Exception NaiveDatabaseException
|
||||
@ -1,106 +1,125 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# HLINT ignore "Use const" #-}
|
||||
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
|
||||
{-# HLINT ignore "Avoid lambda" #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoFieldSelectors #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
|
||||
module Test.Datalog.NaiveDatabaseSpec where
|
||||
|
||||
import Test.Hspec
|
||||
import Datalog.NaiveDatabase
|
||||
import qualified Datalog.NaiveDatabase as NaiveDatabase
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Datalog.DatalogParser
|
||||
import qualified Data.Map as Map
|
||||
import Datalog.NaiveDatabase
|
||||
import Datalog.NaiveDatabase qualified as NaiveDatabase
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "NaiveDatabase operations" $ do
|
||||
describe "NaiveDatabase operations" do
|
||||
it "can ingest facts into relations & a universe" $ do
|
||||
let db = NaiveDatabase.withFacts
|
||||
let db =
|
||||
NaiveDatabase.withFacts
|
||||
[ "parent(\"alice\", \"bob\")."
|
||||
, "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"]])) [] )
|
||||
, "parent(\"bob\", \"carol\")."
|
||||
]
|
||||
it "can ingest facts and rules" $ do
|
||||
let db = NaiveDatabase.withFactsAndRules
|
||||
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
|
||||
let db =
|
||||
NaiveDatabase.withFactsAndRules
|
||||
[ "parent(\"alice\", \"bob\")."
|
||||
, "parent(\"bob\", \"carol\")." ]
|
||||
, "parent(\"bob\", \"carol\")."
|
||||
]
|
||||
[ "ancestor(X,Y) :- parent(X,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"
|
||||
, "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."
|
||||
]
|
||||
},
|
||||
RuleBodyElement {
|
||||
_subRelationId = "ancestor",
|
||||
_ruleElements = [
|
||||
RuleElementVariable "Z",RuleElementVariable "Y"
|
||||
parentRelation =
|
||||
Relation
|
||||
{ _name = "parent"
|
||||
, _arity = 2
|
||||
, _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 {
|
||||
_arity = 2,
|
||||
_name = "ancestor",
|
||||
_tuples = Set.empty,
|
||||
_rules = [ ancestorRule ]
|
||||
ancestorRelation =
|
||||
Relation
|
||||
{ _arity = 2
|
||||
, _name = "ancestor"
|
||||
, _tuples = Set.empty
|
||||
, _rules = [ancestorRule]
|
||||
}
|
||||
relations db `shouldBe`
|
||||
Map.fromList [
|
||||
("ancestor", ancestorRelation),
|
||||
("parent", parentRelation )
|
||||
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
|
||||
let db = NaiveDatabase.withFactsAndRules
|
||||
it "can ingest facts and rules with constants" do
|
||||
let db =
|
||||
NaiveDatabase.withFactsAndRules
|
||||
[]
|
||||
[ "ancestor(X,\"patriarch\") :- ." ]
|
||||
let ancestorRule = RelationRule {
|
||||
headVariables = [ "X" ],
|
||||
bodyElements = []
|
||||
["ancestor(X,\"patriarch\") :- ."]
|
||||
ancestorRule =
|
||||
RelationRule
|
||||
{ headVariables = ["X"]
|
||||
, bodyElements = []
|
||||
}
|
||||
let ancestorRelation = Relation {
|
||||
_arity = 2,
|
||||
_name = "ancestor",
|
||||
_tuples = Set.empty,
|
||||
_rules = [ ancestorRule ]
|
||||
ancestorRelation =
|
||||
Relation
|
||||
{ _arity = 2
|
||||
, _name = "ancestor"
|
||||
, _tuples = Set.empty
|
||||
, _rules = [ancestorRule]
|
||||
}
|
||||
relations db `shouldBe`
|
||||
Map.fromList [
|
||||
("ancestor", ancestorRelation)
|
||||
relations db
|
||||
`shouldBe` Map.fromList
|
||||
[ ("ancestor", ancestorRelation)
|
||||
]
|
||||
|
||||
constants db `shouldBe`
|
||||
(Set.fromList $ Sym <$> ["patriarch"])
|
||||
constants db
|
||||
`shouldBe` (Set.fromList $ Sym <$> ["patriarch"])
|
||||
|
||||
it "can do basic queries" $ do
|
||||
let db = NaiveDatabase.withFacts
|
||||
it "can do basic queries" do
|
||||
let db =
|
||||
NaiveDatabase.withFacts
|
||||
[ "parent(\"alice\", \"bob\")."
|
||||
, "parent(\"bob\", \"carol\")." ]
|
||||
, "parent(\"bob\", \"carol\")."
|
||||
]
|
||||
query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user