diff --git a/haskell-experiments/haskell-experiments.cabal b/haskell-experiments/haskell-experiments.cabal index ddbb6b4..5d9f7db 100644 --- a/haskell-experiments/haskell-experiments.cabal +++ b/haskell-experiments/haskell-experiments.cabal @@ -87,11 +87,16 @@ test-suite haskell-exps-test library langfeatures build-depends: base, containers, megaparsec, parser-combinators, text hs-source-dirs: src - exposed-modules: Ologs, SimpleParser, ArithmeticParser, Datalog.DatalogParser, Datalog.NaiveDatabase + exposed-modules: Ologs + SimpleParser + ArithmeticParser + Datalog.DatalogParser + Datalog.NaiveDatabase + Datalog.Rules ghc-options: -Wall default-extensions: OverloadedStrings - + executable haskell-experiments build-depends: base, containers main-is: Main.hs diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index 0b0dc23..1727fe1 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs @@ -17,40 +17,13 @@ import Data.Text (Text) import Data.Void import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog) import Text.Megaparsec (ParseErrorBundle) +import Datalog.Rules data NaiveDatabase = NaiveDatabase { relations :: Map RelationId Relation , constants :: Set Constant } deriving (Show, Eq) -data RuleElement -- entry occurring in a head or body relation - constant or variable - = RuleElementConstant Constant - | RuleElementVariable Int - deriving (Show, Eq) - -data RuleBodyElement = RuleBodyElement - { _subRelationId :: RelationId - , _ruleElements :: [RuleElement] - } - 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) - --- Our constants will be the terms of the Datalog grammar - ints/variables/symbols -type Constant = Term -type RelationId = Text emptyDB :: NaiveDatabase emptyDB = @@ -200,38 +173,7 @@ addRule (ruleHead, body) db = } relationMap' = Map.insert relationName relation' relationMap constants' = constants db' --- addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase --- addRule (ruleHead, body) db = --- NaiveDatabase relationMap' constants' --- where --- relationName = predName ruleHead --- terms = arguments ruleHead --- newArity = length terms --- relation = lookupRelation relationName (relations db) newArity Set.empty --- context = digestHead db relation ruleHead --- context' = foldr digestBody context body --- db' = _db context' --- relationMap = relations db' --- relation' = --- Relation --- { _name = _name relation --- , _arity = newArity --- , _tuples = _tuples relation --- , _rules = newRule : _rules relation --- } where --- newRule = --- RelationRule --- { headVariables = _variableNames context' --- , bodyElements = toRuleBodyElement <$> _bodyConstraints context' --- } --- toRuleBodyElement :: BodyConstraint -> RuleBodyElement --- toRuleBodyElement (BodyConstraint subRelation elements) = --- RuleBodyElement { --- _subRelationId = _name subRelation --- , _ruleElements = elements --- } --- relationMap' = Map.insert relationName relation' relationMap --- constants' = constants db' + extractVariableNames :: [Term] -> [Text] extractVariableNames = mapMaybe extractVariableName where extractVariableName :: Term -> Maybe Text diff --git a/haskell-experiments/src/Datalog/Rules.hs b/haskell-experiments/src/Datalog/Rules.hs new file mode 100644 index 0000000..20a5c9e --- /dev/null +++ b/haskell-experiments/src/Datalog/Rules.hs @@ -0,0 +1,48 @@ +{-# HLINT ignore "Redundant flip" #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Datalog.Rules 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 Data.Void +import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog) +import Text.Megaparsec (ParseErrorBundle) + +data RuleElement -- entry occurring in a head or body relation - constant or variable + = RuleElementConstant Constant + | RuleElementVariable Int + deriving (Show, Eq) + +data RuleBodyElement = RuleBodyElement + { _subRelationId :: RelationId + , _ruleElements :: [RuleElement] + } + 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) + +-- Our constants will be the terms of the Datalog grammar - ints/variables/symbols +type Constant = Term +type RelationId = Text diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 7d0a124..7684179 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs @@ -17,6 +17,7 @@ module Test.Datalog.NaiveDatabaseSpec where import Data.Map qualified as Map import Data.Set qualified as Set import Datalog.DatalogParser +import Datalog.Rules import Datalog.NaiveDatabase import Datalog.NaiveDatabase qualified as NaiveDatabase import Test.Hspec