Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial commit

  • Loading branch information...
commit 77609e9114080e2f743bf654499b5ef47522bc69 0 parents
@travitch authored
3  .gitignore
@@ -0,0 +1,3 @@
+TAGS
+dist
+.dir-locals.el
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Tristan Ravitch
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Tristan Ravitch nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
28 datalog.cabal
@@ -0,0 +1,28 @@
+-- Initial datalog.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: datalog
+version: 0.1.0.0
+synopsis: An implementation of datalog in Haskell
+-- description:
+license: BSD3
+license-file: LICENSE
+author: Tristan Ravitch
+maintainer: travitch@cs.wisc.edu
+-- copyright:
+category: Database
+build-type: Simple
+cabal-version: >=1.8
+
+library
+ exposed-modules: Database.Datalog
+ Database.Datalog.Database
+ Database.Datalog.Errors
+ Database.Datalog.Rules
+ Database.Datalog.Stratification
+ Database.Datalog.MagicSets
+ -- other-modules:
+ build-depends: base ==4.5.*, containers, unordered-containers, hashable,
+ failure, text, mtl, hbgl
+ hs-source-dirs: src
+ ghc-options: -Wall
58 src/Database/Datalog.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Database.Datalog (
+ -- * Types
+ Database,
+ QueryPlan,
+
+ -- * Evaluating Queries
+ queryDatabase,
+ buildQueryPlan,
+ executeQueryPlan
+ ) where
+
+import Control.Failure
+import Control.Monad.State.Strict ( runStateT )
+import Data.Text ( Text )
+
+import Database.Datalog.Database
+import Database.Datalog.Errors
+import Database.Datalog.Rules
+import Database.Datalog.MagicSets
+import Database.Datalog.Stratification
+
+-- | A fully-stratified query plan
+data QueryPlan a = QueryPlan [[Rule a]]
+
+-- | This is a shortcut ot build a query plan and execute in one step,
+-- with no bindings provided. It doesn't make sense to have bindings
+-- in one-shot queries.
+queryDatabase :: (Failure DatalogError m)
+ => Database a -- ^ The intensional database of facts
+ -> QueryMonad m a (Query a) -- ^ A monad building up a set of rules and returning a Query
+ -> m [Tuple a]
+queryDatabase idb qm = do
+ qp <- buildQueryPlan idb qm
+ executeQueryPlan qp idb []
+
+-- | Given a query description, build a query plan by stratifying the
+-- rules and performing the magic sets transformation. Throws an
+-- error if the rules cannot be stratified.
+buildQueryPlan :: (Failure DatalogError m)
+ => Database a
+ -> QueryMonad m a (Query a)
+ -> m (QueryPlan a)
+buildQueryPlan idb qm = do
+ let ipreds = databasePredicates idb
+ (q, QueryState _ rs) <- runStateT qm (QueryState idb [])
+ rs' <- magicSetsRules ipreds q rs
+ strata <- stratifyRules rs'
+ return $! QueryPlan strata
+
+
+-- | Execute a query plan with an intensional database and a set of
+-- bindings (substituted in for 'BindVar's). Throw an error if:
+--
+-- * The rules and database define the same relation
+executeQueryPlan :: (Failure DatalogError m)
+ => QueryPlan a -> Database a -> [(Text, a)] -> m [Tuple a]
+executeQueryPlan qp idb bindings = undefined
146 src/Database/Datalog/Database.hs
@@ -0,0 +1,146 @@
+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
+module Database.Datalog.Database (
+ Schema,
+ Relation(..),
+ Database,
+ DatabaseBuilder,
+ Predicate(..),
+ Tuple,
+ -- * Functions
+ makeDatabase,
+ addRelation,
+ assertFact,
+ databasePredicates
+ ) where
+
+import Control.Failure
+import Control.Monad.State.Strict
+import Data.Hashable
+import Data.HashMap.Strict ( HashMap )
+import qualified Data.HashMap.Strict as HM
+import Data.HashSet ( HashSet )
+import qualified Data.HashSet as HS
+import Data.Monoid
+import Data.Text ( Text )
+
+import Database.Datalog.Errors
+
+-- | The schema of a relation, naming each column
+newtype Schema = Schema [Text]
+ deriving (Show)
+
+-- | A wrapper around lists that lets us more easily hide length
+-- checks
+newtype Tuple a = Tuple [a]
+ deriving (Eq, Show)
+
+instance (Hashable a) => Hashable (Tuple a) where
+ hash (Tuple es) = hash es
+
+
+
+data Predicate = RelationPredicate Relation
+ | InferencePredicate Text
+ deriving (Eq)
+
+instance Hashable Predicate where
+ hash (InferencePredicate t) = hash t
+ hash (RelationPredicate (Relation t)) = hash t
+
+-- | A relation whose elements are fixed-length lists of a
+-- user-defined type. This is only used internally and is not exposed
+-- to the user.
+data DBRelation a = DBRelation { relationSchema :: Schema
+ , relationName :: Text
+ , relationData :: HashSet (Tuple a)
+ , relationIndex :: HashMap (Int, a) (Tuple a)
+ }
+ deriving (Show)
+
+mergeRelations :: DBRelation a -> DBRelation a -> DBRelation a
+mergeRelations = undefined
+
+data Database a = Database (HashMap Text (DBRelation a))
+
+databasePredicates :: Database a -> [Predicate]
+databasePredicates (Database m) =
+ map (RelationPredicate . Relation) (HM.keys m)
+
+instance Monoid (Database a) where
+ mempty = Database mempty
+ mappend (Database m1) (Database m2) =
+ Database (HM.unionWith mergeRelations m1 m2)
+
+newtype Relation = Relation Text
+ deriving (Eq)
+type DatabaseBuilder m a = StateT (Database a) m
+
+-- | Make a new fact Database in a DatabaseBuilder monad. It can
+-- fail, and errors will be returned however the caller indicates.
+makeDatabase :: (Failure DatalogError m)
+ => DatabaseBuilder m a () -> m (Database a)
+makeDatabase b = execStateT b mempty
+
+-- | Add a tuple to the named 'Relation' in the database. If the
+-- tuple is already present, the original 'Database' is unchanged.
+assertFact :: (Failure DatalogError m, Eq a, Hashable a)
+ => Relation -> [a] -> DatabaseBuilder m a ()
+assertFact relHandle@(Relation t) tup = do
+ db@(Database m) <- get
+ let rel = databaseRelation db relHandle
+ wrappedTuple <- toWrappedTuple rel tup
+ case HS.member wrappedTuple (relationData rel) of
+ True -> return ()
+ False ->
+ let rel' = addTupleToRelation rel wrappedTuple
+ in put $! Database $ HM.insert t rel' m
+
+-- | Add a relation to the 'Database'. If the relation exists, an
+-- error will be raised. The function returns a 'RelationHandle' that
+-- can be used in conjuction with 'addTuple'.
+addRelation :: (Failure DatalogError m, Eq a, Hashable a)
+ => Text -> Schema -> DatabaseBuilder m a Relation
+addRelation name schema = do
+ Database m <- get
+ case HM.lookup name m of
+ Just _ -> lift $ failure (RelationExistsError name)
+ Nothing -> do
+ let r = DBRelation schema name mempty mempty
+ put $! Database $! HM.insert name r m
+ return $! Relation name
+
+-- | Convert the user-level tuple to a safe length-checked Tuple.
+-- Signals failure (according to @m@) if the length is invalid.
+--
+-- FIXME: It would also be nice to be able to check the column type...
+toWrappedTuple :: (Failure DatalogError m)
+ => DBRelation a -> [a] -> DatabaseBuilder m a (Tuple a)
+toWrappedTuple rel tup =
+ case length s == length tup of
+ False -> lift $ failure (SchemaError (relationName rel))
+ True -> return $! Tuple tup
+ where
+ Schema s = relationSchema rel
+
+-- | Add the given tuple to the given 'Relation'. It updates the
+-- index in the process. The 'Tuple' is already validated so this is
+-- a total function.
+--
+-- It has already been verified that the tuple does not exist in the
+-- relation (see 'addTuple') so no extra checks are required here.
+addTupleToRelation :: (Eq a, Hashable a) => DBRelation a -> Tuple a -> DBRelation a
+addTupleToRelation rel t@(Tuple elems) =
+ rel { relationData = HS.insert t (relationData rel)
+ , relationIndex = foldr updateIndex (relationIndex rel) (zip [0..] elems)
+ }
+ where
+ updateIndex ie = HM.insert ie t
+
+databaseRelation :: Database a -> Relation -> DBRelation a
+databaseRelation (Database m) (Relation t) =
+ case HM.lookup t m of
+ -- This really shouldn't be possible - it would be an error in the
+ -- API since users can't create them and they can only be obtained
+ -- in the same monad with the Database
+ Nothing -> error ("Invalid RelationHandle: " ++ show t)
+ Just r -> r
16 src/Database/Datalog/Errors.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Database.Datalog.Errors ( DatalogError(..) ) where
+
+import Control.Exception
+import Data.Text ( Text )
+import Data.Typeable
+
+data DatalogError = SchemaError Text
+ | RelationExistsError Text
+ | NoRelationError Text
+ | MissingQueryError
+ | ExtraQueryError
+ | StratificationError
+ deriving (Typeable, Show)
+
+instance Exception DatalogError
16 src/Database/Datalog/MagicSets.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Database.Datalog.MagicSets where
+
+import Control.Failure
+
+import Database.Datalog.Database
+import Database.Datalog.Errors
+import Database.Datalog.Rules
+
+-- | Returns the rules generated by the magic sets transformation
+magicSetsRules :: (Failure DatalogError m)
+ => [Predicate] -- ^ Predicates used in the intensional database
+ -> Query a -- ^ The goal query
+ -> [Rule a] -- ^ The user-provided rules
+ -> m [Rule a]
+magicSetsRules ipreds q rs = return rs
93 src/Database/Datalog/Rules.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Database.Datalog.Rules (
+ Term(..),
+ Clause(..),
+ Rule(..),
+ Query,
+ QueryMonad,
+ QueryState(..),
+ BodyClause(..),
+ (|-),
+ assertRule,
+ relationPredicateFromName,
+ rulePredicates
+ ) where
+
+import Control.Failure
+import Control.Monad.State.Strict
+import Data.Maybe ( mapMaybe )
+import Data.Text ( Text )
+
+import Database.Datalog.Errors
+import Database.Datalog.Database
+
+data Term a = LogicVar !Text
+ -- ^ A basic logic variable. Equality is based on the
+ -- variable name.
+ | BindVar !Text
+ -- ^ A special variable available in queries that can be
+ -- bound at query execution time
+ | Literal a
+ -- ^ A user-provided literal from the domain a
+
+data Clause a = Clause { clausePredicate :: Predicate
+ , clauseTerms :: [Term a]
+ }
+
+-- | Body clauses can be normal clauses, negated clauses, or
+-- conditionals. Conditionals are arbitrary-arity (via a list)
+-- functions over literals and logic variables.
+data BodyClause a = BodyClause (Clause a)
+ | NegatedClause (Clause a)
+ | ConditionalClause ([a] -> Bool) [Term a]
+
+-- | A rule has a head and body clauses. Body clauses can be normal
+-- clauses, negated clauses, or conditionals.
+data Rule a = Rule { ruleHead :: Clause a
+ , ruleBody :: [BodyClause a]
+ }
+
+bodyClausePredicate :: BodyClause a -> Maybe Predicate
+bodyClausePredicate bc =
+ case bc of
+ BodyClause c -> Just $ clausePredicate c
+ NegatedClause c -> Just $ clausePredicate c
+ _ -> Nothing
+
+rulePredicates :: Rule a -> [Predicate]
+rulePredicates (Rule h bcs) = clausePredicate h : mapMaybe bodyClausePredicate bcs
+
+newtype Query a = Query { unQuery :: Clause a }
+
+infixr 0 |-
+
+-- | Assert a rule
+(|-) :: (Failure DatalogError m) => Clause a -> [BodyClause a] -> QueryMonad m a ()
+(|-) = assertRule
+
+assertRule :: (Failure DatalogError m) => Clause a -> [BodyClause a] -> QueryMonad m a ()
+assertRule h b = do
+ s <- get
+ put s { queryRules = Rule h b : queryRules s }
+
+
+
+-- | Retrieve a Relation handle from the IDB. If the Relation does
+-- not exist, an error will be raised.
+relationPredicateFromName :: (Failure DatalogError m)
+ => Text -> QueryMonad m a Predicate
+relationPredicateFromName name = do
+ idb <- gets intensionalDatabase
+ case RelationPredicate (Relation name) `elem` databasePredicates idb of
+ False -> lift $ failure (NoRelationError name)
+ True -> return $! (RelationPredicate (Relation name))
+
+inferencePredicate :: (Failure DatalogError m)
+ => Text -> QueryMonad m a Predicate
+inferencePredicate = return . InferencePredicate
+
+
+data QueryState a = QueryState { intensionalDatabase :: Database a
+ , queryRules :: [Rule a]
+ }
+type QueryMonad m a = StateT (QueryState a) m
84 src/Database/Datalog/Stratification.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Database.Datalog.Stratification ( stratifyRules ) where
+
+import Control.Failure
+import Data.Hashable
+import Data.HashMap.Strict ( HashMap )
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+import Data.Monoid
+
+import Data.Graph.Interface
+import Data.Graph.LazyHAMT
+import Data.Graph.Algorithms.Matching.DFS
+
+import Database.Datalog.Database
+import Database.Datalog.Errors
+import Database.Datalog.Rules
+
+
+data RuleDep = DepNormal | DepNegated
+ deriving (Eq, Ord)
+type RuleDepGraph = Gr Predicate RuleDep
+
+
+-- | Stratify the input rules and magic rules; the rules should be
+-- processed to a fixed-point in this order
+stratifyRules :: (Failure DatalogError m) => [Rule a] -> m [[Rule a]]
+stratifyRules rs =
+ -- Visit the graph bottom-up (from the leaves) and assign stratum
+ -- numbers on the fly.
+ case any hasInternalNegation comps of
+ True -> failure StratificationError
+ False -> undefined
+ where
+ (g, predToId, predFromId) = makeRuleDepGraph rs
+ g' :: Gr [LNode RuleDepGraph] ()
+ g' = condense g
+ comps :: [[LNode RuleDepGraph]]
+ comps = topsort' g'
+
+ stratumNumbers :: HashMap Predicate Int
+ stratumNumbers = foldr computeStratumNumber mempty comps
+
+ hasInternalNegation :: [LNode RuleDepGraph] -> Bool
+ hasInternalNegation ns =
+ let nids = map unlabelNode ns
+ allOutEdges = concatMap (lsuc g) nids
+ negatedEdges = filter ((==DepNegated) . snd) allOutEdges
+ internalNegatedEdges = filter ((`elem` nids) . fst) negatedEdges
+ in null internalNegatedEdges
+
+computeStratumNumber = undefined
+
+makeRuleDepGraph :: [Rule a] -> (RuleDepGraph, Predicate -> Int, Int -> Predicate)
+makeRuleDepGraph rs = (mkGraph ns es, predToId, predFromId)
+ where
+ preds = unique $ concatMap rulePredicates rs
+ ns = zipWith LNode [0..] preds
+
+ predToIdMap = HM.fromList $ zip preds [0..]
+ predToId p = HM.lookupDefault (error "Missing predicate in predToIdMap") p predToIdMap
+
+ predFromIdMap = HM.fromList $ zip [0..] preds
+ predFromId p = HM.lookupDefault (error "Missing predicate in predFromIdMap") p predFromIdMap
+
+ es = foldr ruleToEdges [] rs
+ -- | Make an edge from the predicate in the head of the rule to
+ -- each predicate in the body. The edge should have a DepNegated
+ -- label if the clause is a negated clause.
+ ruleToEdges r acc =
+ let headPred = clausePredicate (ruleHead r)
+ src = predToId headPred
+ in foldr (toEdge src) acc (ruleBody r)
+ toEdge src bc acc =
+ case bc of
+ ConditionalClause _ _ -> acc
+ NegatedClause (Clause h _) ->
+ LEdge (Edge src (predToId h)) DepNegated : acc
+ BodyClause (Clause h _) ->
+ LEdge (Edge src (predToId h)) DepNormal : acc
+
+
+unique :: (Hashable a, Eq a) => [a] -> [a]
+unique = HS.toList . HS.fromList
Please sign in to comment.
Something went wrong with that request. Please try again.