diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2010, Henning Thielemann + +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. + + * The names of contributors may not 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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,16 @@ +.PHONY: ghci test build docs + +ghci: + ghci -Wall -i:src src/Example/QueryMonad.hs + +test: build docs + +build: + runhaskell Setup configure --user + runhaskell Setup build + runhaskell Setup haddock + +docs: doc/slides.pdf + +doc/slides.pdf: doc/slides.tex + (cd doc; pdflatex slides) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/database-study.cabal b/database-study.cabal new file mode 100644 --- /dev/null +++ b/database-study.cabal @@ -0,0 +1,57 @@ +Name: database-study +Version: 0.0.1 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://dbs.informatik.uni-halle.de/Lehre/LP09/ +Category: Monads, Database +Synopsis: Demonstrate how a database can be implemented the functional way +Description: + This package consists of some toy modules + that translate the well-known company database example. + We show how to implement various queries and database updates + in a way that is both simple and clean. + + It is recommended to download the package with @cabal fetch@, + extract it in a local directory and run @make ghci@. + Additionally open a text editor and follow the examples in the @Example@ directory. + The first queries in the modules + "Example.RelationalAlgebra" and "Example.QueryMonad" + are the same but in different styles. +Tested-With: GHC==6.10.4 +Cabal-Version: >=1.6 +Build-Type: Simple +Extra-Source-Files: + Makefile + +Source-Repository head + type: darcs + location: http://code.haskell.org/~thielema/database-study/ + +Source-Repository this + type: darcs + location: http://code.haskell.org/~thielema/database-study/ + tag: 0.0.1 + +Flag splitBase + description: Choose the new smaller, split-up base package. + +Library + Build-Depends: + containers >=0.1 && <0.4 + If flag(splitBase) + Build-Depends: base >= 2 && <6 + Else + Build-Depends: base >= 1.0 && < 2, special-functors >=1.0 && <1.1 + + GHC-Options: -Wall + Hs-Source-Dirs: src + Exposed-Modules: + Company + Query + Table +-- Other-Modules: + Example.RelationalAlgebra + Example.QueryMonad + Example.UpdateMonad diff --git a/src/Company.hs b/src/Company.hs new file mode 100644 --- /dev/null +++ b/src/Company.hs @@ -0,0 +1,63 @@ +module Company where + +newtype DeptNo = DeptNo Int + deriving (Eq, Ord, Show) + +data Dept = + Dept { + deptnoDept :: DeptNo, + dname :: String, + loc :: String + } + deriving (Eq, Ord, Show) + +dept :: [Dept] +dept = + Dept (DeptNo 10) "ACCOUNTING" "NEW YORK" : + Dept (DeptNo 20) "RESEARCH" "DALLAS" : + Dept (DeptNo 30) "SALES" "CHICAGO" : + Dept (DeptNo 40) "OPERATIONS" "BOSTON" : + [] + + + +data Job = + Clerk | Salesman | Manager | Analyst | President + deriving (Eq, Ord, Enum, Show, Bounded) + +newtype EmpNo = EmpNo Int + deriving (Eq, Ord, Show) + +data Emp = + Emp { + empno :: EmpNo, + ename :: String, + job :: Job, + mgr :: Maybe EmpNo, + sal :: Int, + deptnoEmp :: DeptNo + } + deriving (Eq, Ord, Show) + +emp :: [Emp] +emp = + Emp (EmpNo 7369) "SMITH" Clerk (Just (EmpNo 7902)) 800 (DeptNo 20) : + Emp (EmpNo 7499) "ALLEN" Salesman (Just (EmpNo 7698)) 1600 (DeptNo 30) : + Emp (EmpNo 7521) "WARD" Salesman (Just (EmpNo 7698)) 1250 (DeptNo 30) : + Emp (EmpNo 7566) "JONES" Manager (Just (EmpNo 7839)) 2975 (DeptNo 20) : + Emp (EmpNo 7654) "MARTIN" Salesman (Just (EmpNo 7698)) 1250 (DeptNo 30) : + Emp (EmpNo 7698) "BLAKE" Manager (Just (EmpNo 7839)) 2850 (DeptNo 30) : + Emp (EmpNo 7782) "CLARK" Manager (Just (EmpNo 7839)) 2450 (DeptNo 10) : + Emp (EmpNo 7788) "SCOTT" Analyst (Just (EmpNo 7566)) 3000 (DeptNo 20) : + Emp (EmpNo 7839) "KING" President Nothing 5000 (DeptNo 10) : + Emp (EmpNo 7844) "TURNER" Salesman (Just (EmpNo 7698)) 1500 (DeptNo 30) : + Emp (EmpNo 7876) "ADAMS" Clerk (Just (EmpNo 7788)) 1100 (DeptNo 20) : + Emp (EmpNo 7900) "JAMES" Clerk (Just (EmpNo 7698)) 950 (DeptNo 30) : + Emp (EmpNo 7902) "FORD" Analyst (Just (EmpNo 7566)) 3000 (DeptNo 20) : + Emp (EmpNo 7934) "MILLER" Clerk (Just (EmpNo 7782)) 1300 (DeptNo 10) : + [] + + +class DeptNoField r where deptno :: r -> DeptNo +instance DeptNoField Dept where deptno = deptnoDept +instance DeptNoField Emp where deptno = deptnoEmp diff --git a/src/Example/QueryMonad.hs b/src/Example/QueryMonad.hs new file mode 100644 --- /dev/null +++ b/src/Example/QueryMonad.hs @@ -0,0 +1,213 @@ +{- | +some queries implemented using the list monad + +A special Table type instead of plain lists +could provide an efficient implementation. +-} +module Example.QueryMonad where + +-- unqualified import for simplified usage in GHCi +import Query +import Company + +import Data.Function (on, ) +import Data.List (nub, nubBy, sortBy, maximumBy, ) +import Data.Ord (comparing, ) +import Control.Monad (guard, ) + + +{- | +all employees +-} +employees :: [Emp] +employees = emp + +{- | +all clerks +-} +clerks :: [Emp] +clerks = do + e <- emp + guard (job e == Clerk) + return e + +{- | +all clerks with salary at least 1000 +-} +richClerks :: [Emp] +richClerks = do + e <- emp + guard (job e == Clerk && sal e >= 1000) + return e + +{- | +all employees in research department +-} +researchers :: [Emp] +researchers = do + e <- emp + d <- dept + guard (deptno e == deptno d && dname d == "RESEARCH") + return e + +researchers0 :: [Emp] +researchers0 = do + d <- dept + guard (dname d == "RESEARCH") + e <- emp + guard (deptno e == deptno d) + return e + +{- | +names of all employees and their managers +if the employee has a manager so far +-} +managers :: [(String, String)] +managers = do + e <- emp + m <- emp + guard (Just (empno m) == mgr e) + return (ename e, ename m) + +{- | +names of all employees and their managers; +if the employee has no manager, return an empty string +-} +managers0 :: [(String, String)] +managers0 = do + e <- emp + mname <- + case mgr e of + Nothing -> + return "" + Just mgre -> do + m <- emp + guard (empno m == mgre) + return (ename m) + return (ename e, mname) + +{- | +names of managers that have at least one employee +-} +realManagers :: [String] +realManagers = nub $ do + e <- emp + m <- emp + guard (Just (empno m) == mgr e) + return (ename m) + +{- | +managers that have at least one employee +-} +realManagersFull :: [Emp] +realManagersFull = + nubBy ((==) `on` ename) $ do + e <- emp + m <- emp + guard (Just (empno m) == mgr e) + return m + +{- | +managers that have at least one employee, sorted by their names. +-} +realManagersSortedFull :: [Emp] +realManagersSortedFull = + sortBy (comparing ename) $ + nubBy ((==) `on` ename) $ do + e <- emp + m <- emp + guard (Just (empno m) == mgr e) + return m + +{- | +maximum salary amongst all employees +-} +maximumSalary :: Int +maximumSalary = maximum $ do + e <- emp + return (sal e) + +{- | +employee with maximum salary without a back-join +-} +richestEmployee :: Emp +richestEmployee = + maximumBy (comparing sal) emp + +{- | +employees grouped by their managers +implemented with a sub-query +-} +teams :: [(String, [String])] +teams = do + m <- emp + let es = do + e <- emp + guard (Just (empno m) == mgr e) + return (ename e) + guard (not (null es)) + return (ename m, es) + +{- | +employees grouped by their managers +implemented with a GROUP BY +-} +teams0 :: [(String, [String])] +teams0 = do + (mm,es) <- groupBy mgr emp + m <- emp + guard (Just (empno m) == mm) + return (ename m, map ename es) + +{- | +average salary in each department +-} +averageSalariesInDepartments :: [(String, Int)] +averageSalariesInDepartments = do + (dm,es) <- groupBy deptno emp + d <- dept + guard (deptno d == dm) + return (dname d, Query.averageInt (map sal es)) + + +{- | +manager with most employees +-} +managerOfLargestTeam :: (String, Int) +managerOfLargestTeam = maximumBy (comparing snd) $ do + (mm,es) <- groupBy mgr emp + m <- emp + guard (Just (empno m) == mm) + return (ename m, length es) + + +{- | +A recursive query: +Compute the total salary for each manager +and the total set of employees he conducts. +-} +teamSalaries0 :: [(String, Int)] +teamSalaries0 = + let recurse mgrsal mgrno = + (\(sals,emps) -> + let s = mgrsal + sum sals + in (s, (mgrno, s) : concat emps)) $ + unzip $ + map (\e -> recurse (sal e) (Just (empno e))) $ + filter (\e -> mgr e == mgrno) emp + in do (mno,esal) <- snd (recurse 0 Nothing) + e <- emp + guard (Just (empno e) == mno) + return (ename e, esal) + +teamSalaries :: [(String, Int)] +teamSalaries = + let recurse mgrno = + (\(sals,emps) -> (sum sals, concat emps)) $ + unzip $ + map (\e -> + let (teamSal, team) = recurse (Just (empno e)) + totalSal = teamSal + sal e + in (totalSal, (ename e, totalSal) : team)) $ + filter (\e -> mgr e == mgrno) emp + in snd (recurse Nothing) diff --git a/src/Example/RelationalAlgebra.hs b/src/Example/RelationalAlgebra.hs new file mode 100644 --- /dev/null +++ b/src/Example/RelationalAlgebra.hs @@ -0,0 +1,79 @@ +{- | +some queries implemented using operations from relational algebra +-} +module Example.RelationalAlgebra where + +import Query +import Company + +import qualified Data.Map as Map +import Data.Maybe (isNothing, ) +import qualified Data.Tree as Tree + + +{- | +all employees +-} +employees :: [Emp] +employees = emp + +{- | +all clerks +-} +clerks :: [Emp] +clerks = + filter (\e -> job e == Clerk) emp + +{- | +all clerks with salary at least 1000 +-} +richClerks :: [Emp] +richClerks = + filter (\e -> job e == Clerk && sal e >= 1000) emp + +{- | +all employees in research department +-} +researchers :: [Emp] +researchers = + map fst + (filter (\(e,d) -> deptno e == deptno d && dname d == "RESEARCH") + (cross emp dept)) + +researchers0 :: [Emp] +researchers0 = + map snd + (filter (\(d,e) -> deptno e == deptno d) + (cross (filter (\d -> dname d == "RESEARCH") dept) emp)) + + +hierarchy :: Tree.Forest Emp +hierarchy = + let emptrees = + map (\e -> Tree.Node e (filter ((Just (empno e) ==) . mgr . Tree.rootLabel) emptrees)) emp + in filter (isNothing . mgr . Tree.rootLabel) emptrees +{- +putStr $ Tree.drawForest $ map (fmap ename) hierarchy +-} + +hierarchyFast :: Tree.Forest Emp +hierarchyFast = + let emptrees = + Map.fromListWith (++) $ + map + (\e -> (mgr e, [Tree.Node e (Map.findWithDefault [] (Just (empno e)) emptrees)])) + emp + in Map.findWithDefault [] Nothing emptrees + + +{- | +A recursive query: +Compute the total salary for each manager +and the total set of employees he conducts. +-} +teamSalaries :: [(String, Int)] +teamSalaries = + let recurse (Tree.Node e sub0) = + let sub1 = map recurse sub0 + in Tree.Node (ename e, sal e + sum (map (snd . Tree.rootLabel) sub1)) sub1 + in Tree.flatten =<< map recurse hierarchyFast diff --git a/src/Example/UpdateMonad.hs b/src/Example/UpdateMonad.hs new file mode 100644 --- /dev/null +++ b/src/Example/UpdateMonad.hs @@ -0,0 +1,46 @@ +{- | +demonstrate mutable tables +-} +module Example.UpdateMonad where + +import Company +import Query (showTable, ) +import qualified Query +import qualified Table + +import Control.Monad (guard, ) + + +main :: IO () +main = do + empTable <- Table.create emp + deptTable <- Table.create dept + + Table.insert empTable + (Emp + (EmpNo 7974) + "LEHMAN" + Clerk + (Just (EmpNo 7788)) + 1020 + (DeptNo 20)) + + emp0 <- Table.from empTable + showTable (do + e <- emp0 + guard (job e == Clerk) + return e) + + Table.delete empTable + (\e -> ename e == "WARD") + + Table.update empTable + (\e -> e{sal = sal e + 100}) + + emp1 <- Table.from empTable + dept0 <- Table.from deptTable + showTable (do + (dm,es) <- Query.groupBy deptno emp1 + d <- dept0 + guard (deptno d == dm) + return (dname d, Query.averageInt (map sal es))) diff --git a/src/Query.hs b/src/Query.hs new file mode 100644 --- /dev/null +++ b/src/Query.hs @@ -0,0 +1,36 @@ +module Query where + +import Control.Monad (liftM2, ) +import Data.List (genericLength, ) +import qualified Data.Map as Map + + +showTable :: Show a => [a] -> IO () +showTable = + mapM_ print + +cross :: [a] -> [b] -> [(a,b)] +cross = liftM2 (,) + +join :: (Eq f) => + (a -> f) -> (b -> f) -> [a] -> [b] -> [(a,b)] +join af bf as bs = + filter (\(a,b) -> af a == bf b) $ + liftM2 (,) as bs + +average :: (Fractional a) => [a] -> a +average xs = + sum xs / genericLength xs + +averageInt :: (Integral a) => [a] -> a +averageInt xs = + let n = genericLength xs + in div (sum xs + div n 2) n + +groupBy :: + (Ord key) => + (a -> key) -> [a] -> [(key, [a])] +groupBy f = + Map.toAscList . + Map.fromListWith (++) . + map (\a -> (f a, [a])) diff --git a/src/Table.hs b/src/Table.hs new file mode 100644 --- /dev/null +++ b/src/Table.hs @@ -0,0 +1,21 @@ +module Table where + +import Data.IORef (IORef, newIORef, readIORef, modifyIORef, ) + +create :: a -> IO (IORef a) +create = newIORef + +from :: IORef a -> IO a +from = readIORef + +insert :: IORef [a] -> a -> IO () +insert ref a = modifyIORef ref (a:) + +delete :: IORef [a] -> (a -> Bool) -> IO () +delete ref p = modifyIORef ref (filter (not . p)) + +update :: IORef [a] -> (a -> a) -> IO () +update ref f = modifyIORef ref (map f) + +updateWhere :: IORef [a] -> (a -> a) -> (a -> Bool) -> IO () +updateWhere ref f p = modifyIORef ref (map (\x -> if p x then f x else x))