broken test: failing to look up Z

haskell-experiments/src/Datalog/NaiveDatabase.hs

@@ -30,7 +30,7 @@ data NaiveDatabase = NaiveDatabase
 
 data RuleElement -- entry occurring in a head or body relation - constant or variable
   = RuleElementConstant Constant
-  | RuleElementVariable Text
+  | RuleElementVariable Int
   deriving (Show, Eq)
 
 data RuleBodyElement = RuleBodyElement
@@ -93,14 +93,9 @@ 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
-  deriving (Show, Eq)
-
 data BodyConstraint = BodyConstraint
   { _relation :: Relation
-  , _elements :: [ConstraintElement]
+  , _elements :: [RuleElement]
   }
 
 data RuleContext = RuleContext
@@ -128,51 +123,65 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
   digestHead db relation (Literal neg relationName terms) =
     RuleContext
       { __relation = relation
-      , _variableNames = extractVariableNames terms
-      , _headEntries = variables'
+      , _variableNames = variableNames
+      , _headEntries = entries'
       , _bodyConstraints = []
       , _db = NaiveDatabase relationMap' constants'
       }
    where
+    variableNames = extractVariableNames terms
+    headTermToElement :: Term -> RuleElement
+    headTermToElement (Var name) = 
+      case (elemIndex name) variableNames of
+          Just index -> RuleElementVariable index
+          Nothing -> throw $ VariableLookupException name variableNames
+    headTermToElement constant = RuleElementConstant constant
     relationMap :: Map RelationId Relation = relations db
     relationMap' = Map.insert relationName relation relationMap
-    extraVariables = toElement <$> terms
-    variables' = nub extraVariables
-    extraConstants = mapMaybe maybeConstant variables'
+    extraVariables = headTermToElement <$> terms
+    entries' = nub extraVariables
+    extraConstants = mapMaybe maybeConstant entries'
     constants' = Set.union (constants db) $ Set.fromList extraConstants
   digestBody :: RuleContext -> Literal -> RuleContext
   digestBody context (Literal neg subRelationName terms) =
     RuleContext
       { __relation = relation
-      , _variableNames = _variableNames context
+      , _variableNames = variableNames
       , _headEntries = variables'
       , _bodyConstraints = constraints'
       , _db = NaiveDatabase relationMap' constants'
       }
    where
     relation = __relation context
+    variableNames = _variableNames context
+    bodyTermToElement :: Term -> RuleElement
+    bodyTermToElement (Var name) = 
+      case (elemIndex name) variableNames of
+          Just index -> RuleElementVariable index
+          Nothing -> throw $ VariableLookupException name variableNames
+    bodyTermToElement constant = RuleElementConstant constant
     newArity = length terms
     subRelation = lookupRelation subRelationName relationMap newArity Set.empty
     relationMap :: Map RelationId Relation = relations (_db context)
     relationMap' = Map.insert subRelationName subRelation relationMap
-    extraVariables = toElement <$> terms
+    extraVariables = bodyTermToElement <$> terms
     extraConstants = mapMaybe maybeConstant extraVariables
     variables' = nub $ _headEntries context ++ extraVariables
     constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants
     constraints = _bodyConstraints context
-    newConstraint = BodyConstraint subRelation (toConstraint <$> terms)
+    newConstraint = BodyConstraint subRelation variables'
     constraints' = constraints ++ [newConstraint]
-    varIndex :: Text -> Int
-    varIndex name =
-      case elemIndex (RuleElementVariable name) variables' of
-        Just index -> index
-        Nothing -> throw $ VariableLookupException name variables'
-    toConstraint :: Term -> ConstraintElement
-    toConstraint (Var name) = ConstraintElementIndex (varIndex name)
-    toConstraint constant = ConstraintElementConstant constant
+    -- varIndex :: Text -> Int
+    -- varIndex name =
+    --   case elemIndex (RuleElementVariable name) variables' of
+    --     Just index -> index
+    --     Nothing -> throw $ VariableLookupException name variables'
+    -- toConstraint :: Term -> ConstraintElement
+    -- toConstraint (Var name) = ConstraintElementIndex (varIndex name)
+    -- toConstraint constant = ConstraintElementConstant constant
   addRule :: (Literal, [Literal]) -> NaiveDatabase  ->NaiveDatabase
   addRule (ruleHead, body) db  =
-    NaiveDatabase newRelationMap constants'
+    NaiveDatabase relationMap' constants'
    where
     relationName = predName ruleHead
     terms = arguments ruleHead
@@ -182,25 +191,24 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
     context' = foldl digestBody context body
     db' = _db context'
     relationMap = relations db'
-    variables' = _headEntries context'
-    extractVarName :: RuleElement -> Maybe Text
-    extractVarName (RuleElementVariable varName) = Just varName
-    extractVarName (RuleElementConstant constant) = Nothing
+    -- variables' = _headEntries context'
+    -- extractVarName :: RuleElement -> Maybe Text
+    -- extractVarName (RuleElementVariable varName) = Just varName
+    -- extractVarName (RuleElementConstant constant) = Nothing
     newRule =
       RelationRule
-        { headVariables = mapMaybe extractVarName variables'
-        , bodyElements = fromBodyConstraint <$> _bodyConstraints context'
-        }
-     where
-      fromBodyConstraint :: BodyConstraint -> RuleBodyElement
-      fromBodyConstraint (BodyConstraint subRelation elements) =
-        RuleBodyElement
-          { _subRelationId = _name subRelation
-          , _ruleElements = toRuleElement <$> elements
-          }
-      toRuleElement :: ConstraintElement -> RuleElement
-      toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
-      toRuleElement (ConstraintElementIndex index) = variables' !! index
+        { headVariables = _variableNames context'
+        , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
+        } where
+        toRuleBodyElement :: BodyConstraint -> RuleBodyElement
+        toRuleBodyElement (BodyConstraint subRelation elements) =
+          RuleBodyElement { 
+            _subRelationId = _name subRelation
+            , _ruleElements = elements
+            }
+      -- toRuleElement :: ConstraintElement -> RuleElement
+      -- toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
+      -- toRuleElement (ConstraintElementIndex index) = variables' !! index
     relation' =
       Relation
         { _name = _name relation
@@ -208,11 +216,11 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
         , _tuples = _tuples relation
         , _rules = newRule : _rules relation
         }
-    newRelationMap = Map.insert relationName relation' relationMap
+    relationMap' = Map.insert relationName relation' relationMap
     constants' = constants db'
-  toElement :: Term -> RuleElement
-  toElement (Var name) = RuleElementVariable name
-  toElement constant = RuleElementConstant constant
+  -- toElement :: Term -> RuleElement
+  -- toElement (Var name) = RuleElementVariable name
+  -- toElement constant = RuleElementConstant constant
   extractVariableNames :: [Term] -> [Text]
   extractVariableNames = mapMaybe extractVariableName where
     extractVariableName :: Term -> Maybe Text
@@ -232,7 +240,7 @@ data NaiveDatabaseException
   | NonRuleException Text Statement
   | NonQueryException Text Statement
   | BadArityException Text Int
-  | VariableLookupException Text [RuleElement]
+  | VariableLookupException Text [Text]
   | UnexpectedConstantException Constant
   deriving (Show)
 

haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs

@@ -65,15 +65,15 @@ spec = do
                   [ RuleBodyElement
                       { _subRelationId = "parent"
                       , _ruleElements =
-                          [ RuleElementVariable "X"
-                          , RuleElementVariable "Z"
+                          [ RuleElementVariable 0
+                          , RuleElementVariable 2
                           ]
                       }
                   , RuleBodyElement
                       { _subRelationId = "ancestor"
                       , _ruleElements =
-                          [ RuleElementVariable "Z"
-                          , RuleElementVariable "Y"
+                          [ RuleElementVariable 2
+                          , RuleElementVariable 1
                           ]
                       }
                   ]