delinting with an h

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>" input
+parseExpr =
+  parse (sc *> expr <* eof) "<input>"
 
 -- ┌───────────────────────────────┐
 -- │     Helpful chainl1 alias     │

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                       │

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,23 +179,23 @@ 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'