Permalink
Browse files

Initial commit

  • Loading branch information...
travitch committed Jul 5, 2012
0 parents commit 77609e9114080e2f743bf654499b5ef47522bc69
@@ -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.
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
Oops, something went wrong.

0 comments on commit 77609e9

Please sign in to comment.