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

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Redundant flip" #-}
{-# LANGUAGE ImportQualifiedPost #-}
module Datalog.NaiveDatabase where

import Data.Map (Map)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import qualified Data.Text as T
import Datalog.DatalogParser
import qualified Data.Map as Map
import Text.Megaparsec (ParseErrorBundle)
import Data.Void
import Control.Exception (Exception)
import Control.Exception.Base

data Value =
  ValueInt Int |
  ValueSymbol String

data NaiveDatabase = NaiveDatabase {
  relations :: Map RelationId Relation,
  constants :: Set Constant
}

data Relation = Relation {
  arity :: Int,
  tuples :: Set [Constant]
}

-- newtype RelationId = RelationId Text
--   deriving (Eq, Ord, Show)

-- Our constants will be the terms of the Datalog grammar - ints/variables/symbols
type Constant = Term
type RelationId = Text

-- newtype Constant = Constant Text
--   deriving (Eq, Ord, Show)

emptyDB :: NaiveDatabase
emptyDB = NaiveDatabase {
  relations = Map.empty,
  constants = Set.empty   -- the Herbrand universe
}

withFacts :: [Text] -> NaiveDatabase
withFacts facts =
  foldl addFact emptyDB (extractFact <$> facts) 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
    addFact :: NaiveDatabase -> Literal -> NaiveDatabase
    addFact (NaiveDatabase relations constants) (Literal neg relationName terms) =
      NaiveDatabase newRelations newConstants where
        newRelations =
          case Map.lookup relationName relations of
            Nothing -> relations
            Just relation -> relations
        newConstants = Set.union constants $ Set.fromList terms

query :: NaiveDatabase -> 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

data NaiveDatabaseException
  = CannotParseStatementException Text (ParseErrorBundle Text Void) |
    NonFactException Text Statement |
    NonQueryException Text Statement
  deriving (Show)

instance Exception NaiveDatabaseException