94 lines
2.9 KiB
Haskell
94 lines
2.9 KiB
Haskell
{-# HLINT ignore "Redundant flip" #-}
|
|
{-# LANGUAGE ImportQualifiedPost #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
{-# LANGUAGE InstanceSigs #-}
|
|
{-# LANGUAGE BlockArguments #-}
|
|
|
|
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 (Literal (..), Statement (..), Term (..), parseDatalog)
|
|
import Datalog.Rules
|
|
import Datalog.DatalogDB
|
|
|
|
data NaiveDatabase = NaiveDatabase
|
|
{ relations :: Map RelationId Relation
|
|
, constants :: Set Constant
|
|
} deriving (Show, Eq)
|
|
|
|
|
|
instance DatalogDB NaiveDatabase where
|
|
emptyDB :: NaiveDatabase
|
|
emptyDB = NaiveDatabase
|
|
{ relations = Map.empty
|
|
, constants = Set.empty -- the Herbrand universe
|
|
}
|
|
|
|
lookupRelation :: NaiveDatabase -> Text -> Maybe Relation
|
|
lookupRelation db relationName =
|
|
Map.lookup relationName $ relations db
|
|
|
|
insertRelation :: NaiveDatabase -> Relation -> NaiveDatabase
|
|
insertRelation db relation =
|
|
db {
|
|
relations = Map.insert (_name relation) relation (relations db)
|
|
}
|
|
|
|
addConstants :: NaiveDatabase -> Set Constant -> NaiveDatabase
|
|
addConstants db newConstants =
|
|
db {
|
|
constants = Set.union newConstants (constants db)
|
|
}
|
|
|
|
lookupRelation00 :: DatalogDB db =>
|
|
Text -> db -> Int -> (Relation -> Relation) -> db
|
|
lookupRelation00 relationName db newArity update =
|
|
insertRelation db (update newRelation)
|
|
where
|
|
newRelation = case lookupRelation db relationName of
|
|
Nothing -> Relation relationName newArity Set.empty []
|
|
Just relation ->
|
|
if _arity relation == newArity then
|
|
relation
|
|
else throw $ BadArityException relationName newArity
|
|
|
|
lookupRelation000 :: DatalogDB db =>
|
|
Text -> db -> Int -> Set [Constant] -> (Relation -> Relation) -> db
|
|
lookupRelation000 relationName db newArity tuples update =
|
|
lookupRelation00 relationName db newArity \relation ->
|
|
update relation {
|
|
_tuples = Set.union tuples $ _tuples relation
|
|
}
|
|
|
|
withFacts :: DatalogDB db => [Text] -> db
|
|
withFacts =
|
|
foldr (addFact . extractFact) emptyDB
|
|
where
|
|
extractFact :: Text -> Literal
|
|
extractFact factText =
|
|
case parseDatalog factText of
|
|
Right (Fact fact) -> fact
|
|
Right otherStatement -> throw $ NonFactException factText otherStatement
|
|
Left ex -> throw $ CannotParseStatementException factText ex
|
|
|
|
|
|
withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
|
|
withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
|
|
|
|
query :: forall db . (DatalogDB db) => db -> Text -> Text
|
|
query db qText =
|
|
case parseDatalog qText of
|
|
Right (Query texts literals) -> "#NYI"
|
|
Right otherStatement -> throw $ NonQueryException qText otherStatement
|
|
Left ex -> throw $ CannotParseStatementException qText ex
|
|
|