pyrites/haskell-experiments/src/Datalog/InMemoryDB.hs

{-# HLINT ignore "Redundant flip" #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE BlockArguments #-}

module Datalog.InMemoryDB where

import Control.Exception.Base
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Datalog.DatalogParser (Literal (..), Statement (..), parseDatalog)
import Datalog.Rules
import Datalog.DatalogDB

data InMemoryDB = InMemoryDB
  { relations :: Map RelationId Relation
  , constants :: Set Constant
  } deriving (Show, Eq)


instance DatalogDB InMemoryDB where
  emptyDB :: InMemoryDB
  emptyDB = InMemoryDB
    { relations = Map.empty
    , constants = Set.empty -- the Herbrand universe
    }

  lookupRelation :: InMemoryDB -> Text -> Maybe Relation
  lookupRelation db relationName =
    Map.lookup relationName $ relations db

  insertRelation :: InMemoryDB -> Relation -> InMemoryDB
  insertRelation db relation =
    db {
      relations = Map.insert (_name relation) relation (relations db)
    }

  addConstants :: InMemoryDB -> Set Constant -> InMemoryDB
  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] -> InMemoryDB
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