diff --git a/haskell-experiments/src/ArithmeticParser.hs b/haskell-experiments/src/ArithmeticParser.hs index 5484da6..741695a 100644 --- a/haskell-experiments/src/ArithmeticParser.hs +++ b/haskell-experiments/src/ArithmeticParser.hs @@ -82,8 +82,8 @@ expr = factor `chainl1` addOrSub -- └───────────────────────────────┘ parseExpr :: Text -> Either (ParseErrorBundle Text Void) Expr -parseExpr input = - parse (sc *> expr <* eof) "" input +parseExpr = + parse (sc *> expr <* eof) "" -- ┌───────────────────────────────┐ -- │ Helpful chainl1 alias │ diff --git a/haskell-experiments/src/Datalog/DatalogParser.hs b/haskell-experiments/src/Datalog/DatalogParser.hs index e9ccf3f..19dea5e 100644 --- a/haskell-experiments/src/Datalog/DatalogParser.hs +++ b/haskell-experiments/src/Datalog/DatalogParser.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} module Datalog.DatalogParser where @@ -10,6 +9,7 @@ import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Control.Monad (void) +import Data.Functor (($>)) -- ┌───────────────────────────────────────────────┐ -- │ Basic types │ @@ -29,8 +29,8 @@ data Literal = Literal , arguments :: [Term] } deriving (Show, Eq) -data Head - = HeadSingle Literal -- only case +newtype Head + = HeadSingle Literal deriving (Show, Eq) -- data Head @@ -64,10 +64,11 @@ parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") comma :: Parser () -comma = () <$ symbol "," +comma = void $ symbol "," +-- () <$ symbol "," dot :: Parser () -dot = () <$ symbol "." +dot = void $ symbol "." arrow :: Parser () arrow = void $ symbol ":-" <|> symbol "→" <|> symbol "->" @@ -98,14 +99,17 @@ term = choice -- │ Literal / atom │ -- └───────────────────────────────────────────────┘ + + literal :: Parser Literal literal = do - neg <- (symbol "not" *> sc *> pure False) - <|> (symbol "!" *> sc *> pure False) + neg <- prefixedBy "not" + <|> prefixedBy "!" <|> pure True name <- identifier args <- parens (term `sepBy` comma) <|> pure [] - pure $ Literal neg name args + pure $ Literal neg name args where + prefixedBy op = (symbol op *> sc) $> False -- ┌───────────────────────────────────────────────┐ -- │ Head │ diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index e3771f9..9c720fd 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs @@ -18,10 +18,6 @@ import Data.Void import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog) import Text.Megaparsec (ParseErrorBundle) -data Value - = ValueInt Int - | ValueSymbol String - data NaiveDatabase = NaiveDatabase { relations :: Map RelationId Relation , constants :: Set Constant @@ -63,9 +59,19 @@ emptyDB = , constants = Set.empty -- the Herbrand universe } +lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation +lookupRelation relationName relationMap newArity tuples = + case Map.lookup relationName relationMap of + Nothing -> Relation relationName newArity tuples [] + Just relation -> + if _arity relation == newArity then + let newTuples = Set.union tuples $ _tuples relation + in Relation relationName newArity newTuples [] + else throw $ BadArityException relationName newArity + withFacts :: [Text] -> NaiveDatabase -withFacts facts = - foldr addFact emptyDB (extractFact <$> facts) +withFacts = + foldr (addFact . extractFact) emptyDB where extractFact :: Text -> Literal extractFact factText = @@ -82,16 +88,6 @@ withFacts facts = newRelationMap = Map.insert relationName newRelation relationMap newConstantSet = Set.union constantSet $ Set.fromList terms -lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation -lookupRelation relationName relationMap newArity tuples = - case Map.lookup relationName relationMap of - Nothing -> Relation relationName newArity tuples [] - Just relation -> - if _arity relation == newArity then - let newTuples = Set.union tuples $ _tuples relation - in Relation relationName newArity newTuples [] - else throw $ BadArityException relationName newArity - data BodyConstraint = BodyConstraint { _subRelation :: Relation , _elements :: [RuleElement] @@ -167,7 +163,7 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) lookupVariable :: Text -> [Text] -> Int lookupVariable varName variableNames = - case (elemIndex varName) variableNames of + case elemIndex varName variableNames of Just index -> index Nothing -> throw $ VariableLookupException varName variableNames @@ -183,24 +179,24 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) context' = foldr digestBody context body db' = _db context' relationMap = relations db' - newRule = - RelationRule - { headVariables = _variableNames context' - , bodyElements = toRuleBodyElement <$> _bodyConstraints context' - } where - toRuleBodyElement :: BodyConstraint -> RuleBodyElement - toRuleBodyElement (BodyConstraint subRelation elements) = - RuleBodyElement { - _subRelationId = _name subRelation - , _ruleElements = elements - } 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]