datalog 0.1.0.0 → 0.2.0.1
raw patch · 11 files changed
+379/−94 lines, 11 filesdep +exceptionsdep +haskelinedep +parsecdep −failuredep ~datalogdep ~transformersdep ~vectornew-component:exe:datalog-repl
Dependencies added: exceptions, haskeline, parsec, pretty
Dependencies removed: failure
Dependency ranges changed: datalog, transformers, vector
Files
- datalog.cabal +27/−14
- src/Database/Datalog.hs +9/−13
- src/Database/Datalog/Database.hs +10/−14
- src/Database/Datalog/Evaluate.hs +5/−9
- src/Database/Datalog/MagicSets.hs +9/−9
- src/Database/Datalog/Relation.hs +1/−1
- src/Database/Datalog/Rules.hs +23/−20
- src/Database/Datalog/Stratification.hs +9/−7
- tests/NQueens.hs +2/−1
- tests/WorksForTest.hs +58/−6
- tools/repl/Main.hs +226/−0
datalog.cabal view
@@ -1,13 +1,10 @@--- Initial datalog.cabal generated by cabal init. For further--- documentation, see http://haskell.org/cabal/users-guide/- name: datalog-version: 0.1.0.0+version: 0.2.0.1 synopsis: An implementation of datalog in Haskell license: BSD3 license-file: LICENSE author: Tristan Ravitch-maintainer: travitch@cs.wisc.edu+maintainer: tristan@nochair.net category: Database build-type: Simple cabal-version: >=1.10@@ -16,8 +13,6 @@ any Haskell application. As a consequence, it supports both standard Datalog operations and arbitrary predicates written in Haskell.- .- One day it will have a command-line program as well. library default-language: Haskell2010@@ -34,22 +29,40 @@ containers, unordered-containers, hashable,- failure,+ exceptions >= 0.5 && < 0.7, text,- transformers >= 0.3,- vector >= 0.9+ transformers >= 0.3 && < 0.5,+ vector >= 0.9 && < 0.11 hs-source-dirs: src ghc-options: -Wall -auto-all ghc-prof-options: -auto-all +executable datalog-repl+ default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: tools/repl+ ghc-options: -Wall -auto-all+ build-depends: base == 4.*,+ datalog,+ containers,+ exceptions >= 0.5 && < 0.7,+ hashable,+ haskeline,+ parsec,+ pretty,+ text,+ transformers,+ unordered-containers,+ vector+ test-suite NQueensTest default-language: Haskell2010 hs-source-dirs: tests type: exitcode-stdio-1.0 main-is: NQueens.hs- ghc-options: -Wall -auto-all+ ghc-options: -Wall -auto-all -rtsopts ghc-prof-options: -auto-all- build-depends: datalog == 0.1.0.0,+ build-depends: datalog, base == 4.*, text, containers,@@ -65,7 +78,7 @@ main-is: AncestorTest.hs ghc-options: -Wall ghc-prof-options: -auto-all- build-depends: datalog == 0.1.0.0,+ build-depends: datalog, base == 4.*, text, containers,@@ -80,7 +93,7 @@ main-is: WorksForTest.hs ghc-options: -Wall ghc-prof-options: -auto-all- build-depends: datalog == 0.1.0.0,+ build-depends: datalog, base == 4.*, text, containers,
src/Database/Datalog.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts #-} module Database.Datalog ( -- * Types Database,@@ -9,7 +8,8 @@ QueryPlan, DatalogError(..), Query,- Failure,+ Literal,+ Clause, -- * Building the IDB makeDatabase,@@ -36,7 +36,7 @@ executeQueryPlan ) where -import Control.Failure+import qualified Control.Monad.Catch as E import Control.Monad ( foldM ) import Data.Hashable import Data.Text ( Text )@@ -48,17 +48,14 @@ import Database.Datalog.MagicSets import Database.Datalog.Stratification -import Debug.Trace-import Text.Printf-debug = flip trace- -- | A fully-stratified query plan that is ready to be executed. data QueryPlan a = QueryPlan (Query a) [[Rule a]]+ deriving (Show) -- | This is a shortcut to 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, Eq a, Hashable a, Show a)+queryDatabase :: (E.MonadThrow m, Eq a, Hashable a, Show a) => Database a -- ^ The intensional database of facts -> QueryBuilder m a (Query a) -- ^ A monad building up a set of rules and returning a Query -> m [[a]]@@ -69,7 +66,7 @@ -- | 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, Eq a, Hashable a, Show a)+buildQueryPlan :: (E.MonadThrow m, Eq a, Hashable a, Show a) => Database a -> QueryBuilder m a (Query a) -> m (QueryPlan a)@@ -83,7 +80,7 @@ -- bindings (substituted in for 'BindVar's). Throw an error if: -- -- * The rules and database define the same relation-executeQueryPlan :: (Failure DatalogError m, Eq a, Hashable a, Show a)+executeQueryPlan :: (E.MonadThrow m, Eq a, Hashable a, Show a) => QueryPlan a -> Database a -> [(Text, a)] -> m [[a]] executeQueryPlan (QueryPlan q strata) idb bindings = do -- FIXME: Bindings is used to substitute in values for BoundVars in@@ -95,13 +92,12 @@ let q' = bindQuery q bindings pt = queryToPartialTuple q' p = queryPredicate q'- return $! map unTuple $ select edb p pt -- `debug` show edb-+ return $! map unTuple $ select edb p pt -- Private helpers -- | Apply the rules in each stratum bottom-up. Compute a fixed-point -- for each stratum-applyStrata :: (Failure DatalogError m, Eq a, Hashable a, Show a)+applyStrata :: (E.MonadThrow m, Eq a, Hashable a, Show a) => [[Rule a]] -> Database a -> m (Database a) applyStrata [] db = return db applyStrata ss@(s:strata) db = do
src/Database/Datalog/Database.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-} module Database.Datalog.Database ( Relation, Database,@@ -20,7 +20,7 @@ databaseHasDelta ) where -import Control.Failure+import qualified Control.Monad.Catch as E import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict import Data.Hashable@@ -34,9 +34,6 @@ import Database.Datalog.Errors import Database.Datalog.Relation -import Debug.Trace-debug = flip trace- -- | A wrapper around lists that lets us more easily hide length -- checks newtype Tuple a = Tuple { unTuple :: [a] }@@ -76,19 +73,19 @@ -- | 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)+makeDatabase :: (E.MonadThrow m) => DatabaseBuilder m a () -> m (Database a) makeDatabase b = execStateT b (Database mempty) -- | 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)+addRelation :: (E.MonadThrow m, Eq a, Hashable a) => Text -> Int -> DatabaseBuilder m a Relation addRelation name arity = do Database m <- get case HM.lookup rel m of- Just _ -> lift $ failure (RelationExistsError name)+ Just _ -> lift $ E.throwM (RelationExistsError name) Nothing -> do let r = DBRelation arity rel mempty mempty mempty mempty put $! Database $! HM.insert rel r m@@ -98,7 +95,7 @@ -- | 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)+assertFact :: (E.MonadThrow m, Eq a, Hashable a) => Relation -> [a] -> DatabaseBuilder m a () assertFact relHandle tup = do db@(Database m) <- get@@ -179,11 +176,10 @@ databaseRelations (Database m) = HM.keys m -- | Get all of the tuples for the given predicate/relation in the database.-dataForRelation :: (Failure DatalogError m)- => Database a -> Relation -> m [Tuple a]+dataForRelation :: (E.MonadThrow m) => Database a -> Relation -> m [Tuple a] dataForRelation (Database m) rel = case HM.lookup rel m of- Nothing -> failure $ NoRelationError rel+ Nothing -> E.throwM $ NoRelationError rel Just r -> return $ relationData r databaseHasDelta :: Database a -> Bool@@ -196,9 +192,9 @@ -- 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)+toWrappedTuple :: (E.MonadThrow m) => DBRelation a -> [a] -> DatabaseBuilder m a (Tuple a) toWrappedTuple rel tup = case relationArity rel == length tup of- False -> lift $ failure (SchemaError (relationName rel))+ False -> lift $ E.throwM (SchemaError (relationName rel)) True -> return $! Tuple tup
src/Database/Datalog/Evaluate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -- | This module defines the evaluation strategy of the library. -- -- It currently uses a bottom-up semi-naive evaluator.@@ -8,7 +8,7 @@ ) where import Control.Applicative-import Control.Failure+import qualified Control.Monad.Catch as E import Control.Monad ( foldM, liftM ) import Control.Monad.ST.Strict import Data.Graph@@ -21,12 +21,8 @@ import qualified Data.Vector.Mutable as V import Database.Datalog.Database-import Database.Datalog.Errors import Database.Datalog.Rules -import Debug.Trace-debug = flip trace- -- | Bindings are vectors of values. Each variable in a rule is -- assigned an index in the Bindings during the adornment process. -- When evaluating a rule, if a free variable is encountered, all of@@ -66,7 +62,7 @@ -- -- While collecting all of the new tuples (see projectLiteral), a new -- Δ table is generated.-applyRuleSet :: (Failure DatalogError m, Eq a, Hashable a, Show a)+applyRuleSet :: (E.MonadThrow m, Eq a, Hashable a, Show a) => Database a -> [Rule a] -> m (Database a) applyRuleSet _ [] = error "applyRuleSet: Empty rule set not possible" applyRuleSet db rss@(r:_) = return $ runST $ do@@ -124,8 +120,8 @@ => Database a -> Rule a -> ST s [Bindings s a] applyRule db r = do -- We need to substitute the ΔT table in for *one* occurrence of the- -- T relation in the rule body at a time. It must be substituted in at- -- *each* position where T appears.+ -- T relation in the rule body at a time. It must be substituted in+ -- at *each* position where T appears. case any (referencesRelation hr) b of -- If the relation does not appear in the body at all, we don't -- need to do the delta substitution.
src/Database/Datalog/MagicSets.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE FlexibleContexts, BangPatterns #-}+{-# LANGUAGE BangPatterns #-} module Database.Datalog.MagicSets ( magicSetsRules, seedDatabase ) where -import Control.Failure import Control.Monad ( MonadPlus(..), foldM )+import qualified Control.Monad.Catch as E import Data.Hashable import Data.HashMap.Strict ( HashMap ) import qualified Data.HashMap.Strict as HM@@ -28,7 +28,7 @@ -- Rel[FFF] relation version because we don't transform those into -- versions with bound variables -seedDatabase :: (Failure DatalogError m, Eq a, Hashable a, Show a)+seedDatabase :: (E.MonadThrow m, Eq a, Hashable a, Show a) => Database a -> [Rule a] -> Query a@@ -55,7 +55,7 @@ Atom a -> return (a : tacc, B : bacc) BindVar name -> case lookup name bindings of- Nothing -> failure (NoVariableBinding name)+ Nothing -> E.throwM (NoVariableBinding name) Just v -> return (v : tacc, B : bacc) LogicVar _ -> return (tacc, F : bacc) FreshVar _ -> return (tacc, F : bacc)@@ -83,7 +83,7 @@ -- > (http://www.sciencedirect.com/science/article/pii/074310669190030S) -- -- that handles magic for negated literals.-magicSetsRules :: (Failure DatalogError m, Hashable a, Eq a, Show a)+magicSetsRules :: (E.MonadThrow m, Hashable a, Eq a, Show a) => Query a -- ^ The goal query -> [(Clause a, [Literal Clause a])] -- ^ The user-provided rules -> m [Rule a]@@ -124,7 +124,7 @@ -- head area *always* bound). The QueryPattern is separate and is -- only used to compute other QueryPatterns for the worklist and to -- determine whether or not magic needs to be applied.- magicTransform :: (Failure DatalogError m, Hashable a, Eq a, Show a)+ magicTransform :: (E.MonadThrow m, Hashable a, Eq a, Show a) => QueryPattern -> ([((Clause a, [Literal Clause a]), [QueryPattern])], Seq QueryPattern) -> (Clause a, [Literal Clause a])@@ -287,7 +287,7 @@ -- bound in the query are bound in the associated rules. -- -- Note: all variables in the head must appear in the body-adornRule :: (Failure DatalogError m, Eq a, Hashable a)+adornRule :: (E.MonadThrow m, Eq a, Hashable a) => (Clause a, [Literal Clause a]) -> m (Rule a) adornRule (hd, lits) = do (vmap, lits') <- mapAccumM adornLiteral mempty lits@@ -297,9 +297,9 @@ -- must appear in a non-negative literal case headVars `HS.difference` (HS.fromList (HM.keys allVars)) == mempty of True -> return $! Rule hd' lits' allVars- False -> failure RangeRestrictionViolation+ False -> E.throwM RangeRestrictionViolation -adornLiteral :: (Failure DatalogError m, Eq a, Hashable a)+adornLiteral :: (E.MonadThrow m, Eq a, Hashable a) => HashMap (Term a) Int -> Literal Clause a -> m (HashMap (Term a) Int, Literal AdornedClause a)
src/Database/Datalog/Relation.hs view
@@ -37,4 +37,4 @@ hashWithSalt s (Relation t) = s `hashWithSalt` t `hashWithSalt` (99 :: Int) hashWithSalt s (MagicRelation p t) =- s `hashWithSalt` p `hashWithSalt` (2 :: Int)+ s `hashWithSalt` p `hashWithSalt` t `hashWithSalt` (2 :: Int)
src/Database/Datalog/Rules.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} -- | FIXME: Change the adornment/query building process such that -- conditional clauses are always processed last. This is necessary -- so that all variables are bound.@@ -35,7 +36,7 @@ partitionRules ) where -import Control.Failure+import qualified Control.Monad.Catch as E import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict import Data.Function ( on )@@ -47,7 +48,7 @@ import Data.Monoid import Data.Text ( Text ) import qualified Data.Text as T-import Text.Printf+import Text.Printf ( printf ) import Database.Datalog.Adornment import Database.Datalog.Relation@@ -65,7 +66,7 @@ -- | The Monad in which queries are constructed and rules are declared type QueryBuilder m a = StateT (QueryState a) m -nextConditionalId :: (Failure DatalogError m) => QueryBuilder m a Int+nextConditionalId :: (E.MonadThrow m) => QueryBuilder m a Int nextConditionalId = do s <- get let cid = conditionalIdSource s@@ -169,13 +170,13 @@ hashWithSalt s (ConditionalClause cid _ ts vm) = s `hashWithSalt` cid `hashWithSalt` ts `hashWithSalt` HM.size vm -lit :: (Failure DatalogError m) => Relation -> [Term a] -> QueryBuilder m a (Literal Clause a)+lit :: (E.MonadThrow m) => Relation -> [Term a] -> QueryBuilder m a (Literal Clause a) lit p ts = return $ Literal $ Clause p ts -negLit :: (Failure DatalogError m) => Relation -> [Term a] -> QueryBuilder m a (Literal Clause a)+negLit :: (E.MonadThrow m) => Relation -> [Term a] -> QueryBuilder m a (Literal Clause a) negLit p ts = return $ NegatedLiteral $ Clause p ts -cond1 :: (Failure DatalogError m, Eq a, Hashable a)+cond1 :: (E.MonadThrow m, Eq a, Hashable a) => (a -> Bool) -> Term a -> QueryBuilder m a (Literal Clause a)@@ -183,7 +184,7 @@ cid <- nextConditionalId return $ ConditionalClause cid (\[x] -> p x) [t] mempty -cond2 :: (Failure DatalogError m, Eq a, Hashable a)+cond2 :: (E.MonadThrow m, Eq a, Hashable a) => (a -> a -> Bool) -> (Term a, Term a) -> QueryBuilder m a (Literal Clause a)@@ -192,7 +193,7 @@ return $ ConditionalClause cid (\[x1, x2] -> p x1 x2) [t1, t2] mempty -cond3 :: (Failure DatalogError m, Eq a, Hashable a)+cond3 :: (E.MonadThrow m, Eq a, Hashable a) => (a -> a -> a -> Bool) -> (Term a, Term a, Term a) -> QueryBuilder m a (Literal Clause a)@@ -200,7 +201,7 @@ cid <- nextConditionalId return $ ConditionalClause cid (\[x1, x2, x3] -> p x1 x2 x3) [t1, t2, t3] mempty -cond4 :: (Failure DatalogError m, Eq a, Hashable a)+cond4 :: (E.MonadThrow m, Eq a, Hashable a) => (a -> a -> a -> a -> Bool) -> (Term a, Term a, Term a, Term a) -> QueryBuilder m a (Literal Clause a)@@ -208,7 +209,7 @@ cid <- nextConditionalId return $ ConditionalClause cid (\[x1, x2, x3, x4] -> p x1 x2 x3 x4) [t1, t2, t3, t4] mempty -cond5 :: (Failure DatalogError m, Eq a, Hashable a)+cond5 :: (E.MonadThrow m, Eq a, Hashable a) => (a -> a -> a -> a -> a -> Bool) -> (Term a, Term a, Term a, Term a, Term a) -> QueryBuilder m a (Literal Clause a)@@ -240,14 +241,14 @@ s `hashWithSalt` h `hashWithSalt` b `hashWithSalt` HM.size vms newtype Query a = Query { unQuery :: Clause a }-+ deriving (Show) infixr 0 |- -- | Assert a rule -- -- FIXME: Check to make sure that clause arities match their declared -- schema.-(|-), assertRule :: (Failure DatalogError m)+(|-), assertRule :: (E.MonadThrow m) => (Relation, [Term a]) -- ^ The rule head -> [QueryBuilder m a (Literal Clause a)] -- ^ Body literals -> QueryBuilder m a ()@@ -289,18 +290,20 @@ -- | Retrieve a Relation handle from the IDB. If the Relation does -- not exist, an error will be raised.-relationPredicateFromName :: (Failure DatalogError m)- => Text -> QueryBuilder m a Relation+relationPredicateFromName :: (E.MonadThrow m)+ => Text+ -> QueryBuilder m a Relation relationPredicateFromName name = do let rel = Relation name idb <- gets intensionalDatabase case rel `elem` databaseRelations idb of- False -> lift $ failure (NoRelationError rel)+ False -> lift $ E.throwM (NoRelationError rel) True -> return rel -- | Create a new predicate that will be referenced by an EDB rule-inferencePredicate :: (Failure DatalogError m)- => Text -> QueryBuilder m a Relation+inferencePredicate :: (E.MonadThrow m)+ => Text+ -> QueryBuilder m a Relation inferencePredicate = return . Relation -- | A partial tuple records the atoms in a tuple (with their indices@@ -336,7 +339,7 @@ -- | Turn a Clause into a Query. This is meant to be the last -- statement in a QueryBuilder monad.-issueQuery :: (Failure DatalogError m) => Relation -> [Term a] -> QueryBuilder m a (Query a)+issueQuery :: (E.MonadThrow m) => Relation -> [Term a] -> QueryBuilder m a (Query a) issueQuery r ts = return $ Query $ Clause r ts @@ -345,7 +348,7 @@ -- -- Rules are adorned (marking each variable as Free or Bound as they -- appear) before being returned.-runQuery :: (Failure DatalogError m, Eq a, Hashable a)+runQuery :: (E.MonadThrow m, Eq a, Hashable a) => QueryBuilder m a (Query a) -> Database a -> m (Query a, [(Clause a, [Literal Clause a])]) runQuery qm idb = do (q, QueryState _ _ rs) <- runStateT qm (QueryState idb 0 [])
src/Database/Datalog/Stratification.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE FlexibleContexts #-} module Database.Datalog.Stratification ( stratifyRules ) where -import Control.Failure+import qualified Control.Monad.Catch as E+import qualified Data.Foldable as F import Data.HashMap.Strict ( HashMap ) import qualified Data.HashMap.Strict as HM import Data.HashSet ( HashSet )@@ -17,10 +17,10 @@ -- | 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 :: (E.MonadThrow m) => [Rule a] -> m [[Rule a]] stratifyRules rs = case all hasNoInternalNegation comps of- False -> failure StratificationError+ False -> E.throwM StratificationError True -> return $ IM.elems $ foldr (assignRule stratumNumbers) mempty rs where (ctxts, negatedEdges) = makeRuleDependencies rs@@ -34,7 +34,7 @@ internalEdges = foldr (isInternalEdge compNodes) mempty vs in HS.null $ HS.intersection internalEdges negatedEdges - stratumNumbers = foldr (computeStratumNumbers negatedEdges) mempty comps+ stratumNumbers = F.foldl' (computeStratumNumbers negatedEdges) mempty comps isInternalEdge :: HashSet Relation -> Context -> HashSet (Relation, Relation) -> HashSet (Relation, Relation) isInternalEdge compNodes (_, n, tgts) acc =@@ -64,6 +64,8 @@ computeStratumNumber :: NegatedEdges -> HashMap Relation Int -> Context -> Int computeStratumNumber negEdges m (_, r, deps) = case deps of+ -- If this relation has no dependencies, it is in stratum zero and+ -- can be evaluated first [] -> 0 -- deps is not empty; if a dependency is not present it must be in -- this SCC and we can count it as zero because there are no@@ -80,10 +82,10 @@ -- maximum number of negations reachable from a relation without -- encountering a negation (negations within an SCC are impossible). computeStratumNumbers :: NegatedEdges- -> SCC Context -> HashMap Relation Int+ -> SCC Context -> HashMap Relation Int-computeStratumNumbers negEdges comp m =+computeStratumNumbers negEdges m comp = case comp of AcyclicSCC c@(r, _, _) -> HM.insert r (computeStratumNumber negEdges m c) m CyclicSCC cs ->
tests/NQueens.hs view
@@ -21,7 +21,8 @@ type Position = (Int, Int) -dbN :: (Failure DatalogError m) => Int -> m (Database Position)+-- dbN :: (Failure DatalogError m) => Int -> m (Database Position)+dbN :: Int -> IO (Database Position) dbN n = makeDatabase $ do let posTuples = [ (x, y) | x <- [1..n], y <- [1..n] ] position <- addRelation "position" 1
tests/WorksForTest.hs view
@@ -18,6 +18,7 @@ , testCase "2" t2 , testCase "3" t3 , testCase "4" t4+ , testCase "5" t5 ] ] @@ -86,7 +87,7 @@ jobExceptions <- addRelation "jobExceptions" 2 assertFact jobExceptions [ EID 4, J "PC Support" ] -q1 :: (Failure DatalogError m) => QueryBuilder m WorkInfo (Query WorkInfo)+q1 :: QueryBuilder Maybe WorkInfo (Query WorkInfo) q1 = do employee <- relationPredicateFromName "employee" bossOf <- relationPredicateFromName "bossOf"@@ -129,7 +130,7 @@ , [EN "Lilian", EN "Bob"] ] -q2 :: (Failure DatalogError m) => QueryBuilder m WorkInfo (Query WorkInfo)+q2 :: QueryBuilder Maybe WorkInfo (Query WorkInfo) q2 = do employee <- relationPredicateFromName "employee" bossOf <- relationPredicateFromName "bossOf"@@ -166,7 +167,7 @@ ] -q3 :: (Failure DatalogError m) => QueryBuilder m WorkInfo (Query WorkInfo)+q3 :: QueryBuilder Maybe WorkInfo (Query WorkInfo) q3 = do employee <- relationPredicateFromName "employee" bossOf <- relationPredicateFromName "bossOf"@@ -204,9 +205,6 @@ , lit employee [jid, x, Anything, Anything] , negLit jobExceptions [jid, y] ]- --(bj, [x, y]) |- [ lit worksFor [x, y]- -- , negLit empJob [y, Atom (J "PC Support")]- -- ] issueQuery empJob [ BindVar "name", x ] t4 :: Assertion@@ -216,6 +214,60 @@ res <- executeQueryPlan qp db [("name", EN "Li")] assertEqual "t4" expected (fromList res)+ where+ expected = fromList [ [EN "Li", J "PC Support"]+ , [EN "Li", J "Server Support"]+ ]++q4 :: QueryBuilder Maybe WorkInfo (Query WorkInfo)+q4 = do+ employee <- relationPredicateFromName "employee"+ bossOf <- relationPredicateFromName "bossOf"+ worksFor <- inferencePredicate "worksFor"+ empJobStar <- inferencePredicate "employeeJob*"+ empJob <- inferencePredicate "employeeJob"+ empJob2 <- inferencePredicate "employeeJob2"+ canDo <- relationPredicateFromName "canDo"+ jobReplacement <- relationPredicateFromName "jobCanBeDoneBy"+ jobExceptions <- relationPredicateFromName "jobExceptions"+ bj <- inferencePredicate "bj"+ let x = LogicVar "X"+ y = LogicVar "Y"+ z = LogicVar "Z"+ jid = LogicVar "ID"+ pos = LogicVar "Pos"+ eid = LogicVar "E-ID"+ bid = LogicVar "B-ID"+ (worksFor, [x, y]) |- [ lit bossOf [bid, eid]+ , lit employee [eid, x, Anything, Anything]+ , lit employee [bid, y, Anything, Anything]+ ]+ (worksFor, [x, y]) |- [ lit worksFor [x, z]+ , lit worksFor [z, y]+ ]+ (empJobStar, [x, y]) |- [ lit employee [Anything, x, pos, Anything]+ , lit canDo [pos, y]+ ]+ (empJobStar, [x, y]) |- [ lit jobReplacement [y, z]+ , lit empJobStar [x, z]+ ]+ (empJobStar, [x, y]) |- [ lit canDo [Anything, y]+ , lit employee [Anything, x, Atom (EP "Boss"), Anything]+ ]+ (empJob, [x, y]) |- [ lit empJobStar [x, y]+ , lit employee [jid, x, Anything, Anything]+ , negLit jobExceptions [jid, y]+ ]+ (empJob2, [x, y]) |- [ lit empJob [x,y] ]+ issueQuery empJob2 [ BindVar "name", x ]++t5 :: Assertion+t5 = do+ let Just db = db1+ Just qp = buildQueryPlan db q4++ res <- executeQueryPlan qp db [("name", EN "Li")]+ assertEqual "t5" expected (fromList res) where expected = fromList [ [EN "Li", J "PC Support"] , [EN "Li", J "Server Support"]
+ tools/repl/Main.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+module Main ( main ) where++import qualified Control.Monad.Catch as E+import Control.Monad.Trans.Class ( lift )+import Control.Monad.Trans.State.Strict ( evalStateT, StateT, modify, gets )+import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe ( catMaybes )+import Data.Sequence ( Seq, (|>) )+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import Data.Typeable ( Typeable )+import qualified System.Console.Haskeline as HL+import Text.Printf ( printf )++import Database.Datalog++import qualified Parser as P+import qualified Commands as C++main :: IO ()+main = evalStateT (HL.runInputT settings loop) s0+ where+ settings = HL.defaultSettings+ s0 = ReplState { commands = Seq.empty+ , definedRelations = M.empty+ }++type ReplM = StateT ReplState IO++data ReplState = ReplState { commands :: !(Seq C.Command)+ , definedRelations :: !(M.Map String Int)+ }++-- Each time a (non-query) command is entered, just record it in the+-- list. If the command is a query, then "interpret" the whole list+-- of commands as a DatabaseBuilder action and run it to produce a+-- Database. Then execute the query. Displaying facts is just a+-- filter over the list of commands.++loop :: HL.InputT ReplM ()+loop = do+ minput <- HL.getInputLine "% "+ case minput of+ Nothing -> return ()+ Just input -> do+ let cmd = P.parseInput input+ case cmd of+ Left err -> HL.outputStrLn (show err) >> loop+ Right C.DumpFacts -> do+ cs <- lift $ gets commands+ F.forM_ cs $ \c ->+ case c of+ C.AssertFact cl -> HL.outputStrLn (clauseString cl)+ _ -> return ()+ loop+ Right C.DumpRules -> do+ cs <- lift $ gets commands+ F.forM_ cs $ \c -> do+ case c of+ C.AddRule ruleHead ruleBody ->+ HL.outputStrLn (ruleString ruleHead ruleBody)+ _ -> return ()+ loop+ Right (C.Query qc@(C.Clause name _)) -> do+ erows <- lift $ E.try (evaluateQuery qc)+ case erows of+ Left err -> do+ let errAs :: EvaluationError+ errAs = err+ HL.outputStrLn (show errAs)+ loop+ Right rows -> do+ F.forM_ rows $ \row -> do+ let s = L.intercalate ", " row+ HL.outputStrLn $ printf "%s(%s)" name s+ loop+ Right C.Quit -> return ()+ Right C.Help -> printHelp >> loop+ Right c@(C.AssertFact f) -> do+ ok <- guardArity f+ case ok of+ Nothing ->+ lift $ modify $ \s -> s { commands = commands s |> c }+ Just err -> HL.outputStrLn err+ loop+ Right c@(C.AddRule ruleHead ruleBody) -> do+ hres <- guardArity ruleHead+ bress <- mapM guardArity ruleBody+ case catMaybes (hres : bress) of+ [] -> lift $ modify $ \s -> s { commands = commands s |> c }+ errs -> HL.outputStrLn (unlines errs)+ loop++guardArity :: (Show a) => C.Clause a -> HL.InputT ReplM (Maybe String)+guardArity f@(C.Clause name args) = do+ rels <- lift $ gets definedRelations+ case M.lookup name rels of+ Just arity | length args == arity -> return Nothing+ | otherwise ->+ return $ Just ("Arity mismatch: " ++ show f ++ " should have arity " ++ show arity)+ Nothing -> do+ lift $ modify $ \s -> s { definedRelations = M.insert name (length args) (definedRelations s) }+ return Nothing++printHelp :: HL.InputT ReplM ()+printHelp =+ HL.outputStrLn $ unlines [ "Datalog REPL"+ , ""+ , "Commands"+ , " :help - this text"+ , " :quit - exit the repl"+ , " :facts - print all defined facts"+ , " :rules - print all defined rules"+ , ""+ , "Syntax"+ , " To declare a fact:"+ , " relation1(arg1, arg2)."+ , " To define a rule:"+ , " relation2(X, Y) :- relation1(X, Z), relation1(Z, Y)."+ , " To issue a query:"+ , " relation2(X, Y)?"+ , ""+ , " Variables are in all caps. Literals (atoms) begin with a lowercase letter. Relation names also begin with a lowercase letter."+ ]++ruleString :: C.Clause C.AnyValue -> [C.Clause C.AnyValue] -> String+ruleString ruleHead ruleBody =+ concat [ cstring ruleHead+ , " :- "+ , L.intercalate ", " (map cstring ruleBody)+ ]+ where+ cstring (C.Clause name args) =+ let strs = L.intercalate ", " $ map valToString args+ in printf "%s(%s)" name strs+ valToString (C.AVVariable s) = s+ valToString (C.AVLiteral (C.LVString s)) = s++clauseString :: C.Clause C.LiteralValue -> String+clauseString (C.Clause name lits) = printf "%s(%s)" name strs+ where+ strs = L.intercalate ", " $ map litToString lits++litToString :: C.LiteralValue -> String+litToString (C.LVString s) = s++pleatM :: (Monad m, F.Foldable f) => a -> f b -> (a -> b -> m a) -> m a+pleatM seed elts f = F.foldlM f seed elts++evaluateQuery :: C.Clause C.AnyValue -> StateT ReplState IO [[String]]+evaluateQuery (C.Clause name vals) = do+ cs <- gets commands+ db <- makeDatabase $ do+ _ <- pleatM M.empty cs $ \ !a c -> do+ case c of+ C.AssertFact fact@(C.Clause rel factVals) ->+ case M.lookup rel a of+ Nothing -> do+ let arity = length factVals+ r <- addRelation (T.pack rel) arity+ assertFact r (map litToString factVals)+ lift $ modify $ \s -> s { definedRelations = M.insert rel arity (definedRelations s) }+ return $ M.insert rel (r, arity) a+ Just (r, arity) | arity == length factVals -> do+ assertFact r (map litToString factVals)+ return a+ Just (_, arity) -> E.throwM $ ArityMismatch arity fact+ _ -> return a+ return ()+ queryDatabase db $ do+ _ <- pleatM M.empty cs $ \ !a c -> do+ case c of+ C.AddRule h@(C.Clause headRel headVals) body -> do+ a1 <- checkArityDefs a h+ a2 <- F.foldlM checkArityDefs a1 body+ hr <- inferencePredicate (T.pack headRel)+ let headTerms = map toTerm headVals+ bodies = map toBodyClause body+ assertRule (hr, headTerms) bodies+ return a2+ _ -> return a+ qrel <- inferencePredicate (T.pack name)+ issueQuery qrel (map toTerm vals)++toBodyClause :: C.Clause C.AnyValue -> QueryBuilder ReplM String (Literal Clause String)+toBodyClause c@(C.Clause rel vals) = do+ checkArity c+ r <- inferencePredicate (T.pack rel)+ lit r (map toTerm vals)++toTerm :: C.AnyValue -> Term String+toTerm (C.AVVariable v) = LogicVar (T.pack v)+toTerm (C.AVLiteral (C.LVString l)) = Atom l++checkArityDefs :: M.Map String (Relation, Int)+ -> C.Clause C.AnyValue+ -> QueryBuilder ReplM String (M.Map String (Relation, Int))+checkArityDefs defs c@(C.Clause rel vals) = do+ checkArity c+ case M.lookup rel defs of+ Nothing -> do+ r <- inferencePredicate (T.pack rel)+ return $ M.insert rel (r, length vals) defs+ Just (_, arity) | arity == length vals -> return defs+ | otherwise -> E.throwM $ ArityMismatch2 arity c++checkArity :: C.Clause C.AnyValue -> QueryBuilder ReplM String ()+checkArity c@(C.Clause rel vals) = do+ rs <- lift $ gets definedRelations+ case M.lookup rel rs of+ Just arity | carity == arity -> return ()+ | otherwise -> E.throwM $ ArityMismatch2 arity c+ Nothing -> lift $ modify $ \s -> s { definedRelations = M.insert rel carity (definedRelations s) }+ where+ carity = length vals++data EvaluationError = ArityMismatch Int (C.Clause C.LiteralValue)+ | ArityMismatch2 Int (C.Clause C.AnyValue)+ deriving (Eq, Ord, Show, Typeable)++instance E.Exception EvaluationError