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]