diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index 7ced0f6..bc26b71 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs @@ -107,7 +107,7 @@ data BodyConstraint = BodyConstraint data RuleContext = RuleContext { __relation :: Relation , -- _variableNames :: [Text], - _headVariables :: [RuleElement] + _headEntries :: [RuleElement] , _bodyConstraints :: [BodyConstraint] , _db :: NaiveDatabase } @@ -122,7 +122,7 @@ withFactsAndRules facts rules = where extractRule :: Text -> (Literal, [Literal]) extractRule ruleText = - case (parseDatalog ruleText) of + case parseDatalog ruleText of Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs) Right otherStatement -> throw $ NonRuleException ruleText otherStatement Left ex -> throw $ CannotParseStatementException ruleText ex @@ -130,7 +130,7 @@ withFactsAndRules facts rules = digestHead db relation (Literal neg relationName terms) = RuleContext { __relation = relation - , _headVariables = variables' + , _headEntries = variables' , _bodyConstraints = [] , _db = NaiveDatabase relationMap' constants' } @@ -145,7 +145,7 @@ withFactsAndRules facts rules = digestBody context (Literal neg subRelationName terms) = RuleContext { __relation = relation - , _headVariables = variables' + , _headEntries = variables' , _bodyConstraints = constraints' , _db = NaiveDatabase relationMap' constants' } @@ -156,8 +156,8 @@ withFactsAndRules facts rules = relationMap :: Map RelationId Relation = relations (_db context) relationMap' = Map.insert subRelationName subRelation relationMap extraVariables = toElement <$> terms - extraConstants = catMaybes $ maybeConstant <$> extraVariables - variables' = nub $ _headVariables context ++ extraVariables + extraConstants = mapMaybe maybeConstant extraVariables + variables' = nub $ _headEntries context ++ extraVariables constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants constraints = _bodyConstraints context newConstraint = BodyConstraint subRelation (toConstraint <$> terms) @@ -182,14 +182,14 @@ withFactsAndRules facts rules = context'' = foldl digestBody context' body db' = _db context'' relationMap = relations db' - variables' = _headVariables context'' + variables' = _headEntries context'' extractVarName :: RuleElement -> Maybe Text extractVarName (RuleElementVariable varName) = Just varName extractVarName (RuleElementConstant constant) = Nothing newRule = RelationRule - { headVariables = catMaybes $ extractVarName <$> variables' - , bodyElements = fromBodyConstraint <$> (_bodyConstraints context'') + { headVariables = mapMaybe extractVarName variables' + , bodyElements = fromBodyConstraint <$> _bodyConstraints context'' } where fromBodyConstraint :: BodyConstraint -> RuleBodyElement @@ -206,7 +206,7 @@ withFactsAndRules facts rules = { _name = _name relation , _arity = newArity , _tuples = _tuples relation - , _rules = (_rules relation) ++ [newRule] + , _rules = newRule : _rules relation } newRelationMap = Map.insert relationName relation' relationMap constants' = constants db' @@ -216,7 +216,7 @@ withFactsAndRules facts rules = query :: NaiveDatabase -> Text -> Text query db qText = - case (parseDatalog qText) of + case parseDatalog qText of Right (Query texts literals) -> "#NYI" Right otherStatement -> throw $ NonQueryException qText otherStatement Left ex -> throw $ CannotParseStatementException qText ex diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 7c76c01..cea6bfb 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs @@ -10,6 +10,7 @@ {-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Test.Datalog.NaiveDatabaseSpec where @@ -35,7 +36,7 @@ spec = do `shouldBe` Map.fromList [ ( "parent" - , Relation "parent" 2 (Set.fromList $ map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]) [] + , Relation "parent" 2 (Set.fromList $ Sym <<$>> [["alice", "bob"], ["bob", "carol"]]) [] ) ] it "can ingest facts and rules" do @@ -84,7 +85,7 @@ spec = do , _rules = [ancestorRule] } constants db - `shouldBe` (Set.fromList $ Sym <$> ["alice", "bob", "carol"]) + `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"]) relations db `shouldBe` Map.fromList [ ("ancestor", ancestorRelation) @@ -114,7 +115,7 @@ spec = do ] constants db - `shouldBe` (Set.fromList $ Sym <$> ["patriarch"]) + `shouldBe` Set.fromList (Sym <$> ["patriarch"]) it "can do basic queries" do let db = @@ -123,3 +124,13 @@ spec = do , "parent(\"bob\", \"carol\")." ] query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob' + +(<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b) +(<<$>>) = fmap fmap fmap + +-- (<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => f1 (f2 (a -> b)) -> f1 (f2 (f3 a -> f3 b)) +-- (<<<$>>>) :: Functor f => (a1 -> b) -> (a2 -> a1) -> f a2 -> f b +-- (<<<$>>>) :: (Functor f1, Functor f2) => (a1 -> a2 -> b) -> f1 a1 -> f1 (f2 a2 -> f2 b) +-- (<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => f1 (a -> b) -> f1 (f2 (f3 a) -> f2 (f3 b)) +(<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => (a -> b) -> f1 (f2 (f3 a)) -> f1 (f2 (f3 b)) +(<<<$>>>) = fmap fmap fmap fmap fmap fmap fmap fmap