introduce Rules module to factpr out the rule stuff

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

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

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

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