packages feed

database-study (empty) → 0.0.1

raw patch · 10 files changed

+565/−0 lines, 10 filesdep +basedep +containersdep +special-functorssetup-changed

Dependencies added: base, containers, special-functors

Files

+ LICENSE view
@@ -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.
+ Makefile view
@@ -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)
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ database-study.cabal view
@@ -0,0 +1,57 @@+Name:             database-study+Version:          0.0.1+License:          BSD3+License-File:     LICENSE+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+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
+ src/Company.hs view
@@ -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
+ src/Example/QueryMonad.hs view
@@ -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)
+ src/Example/RelationalAlgebra.hs view
@@ -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
+ src/Example/UpdateMonad.hs view
@@ -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)))
+ src/Query.hs view
@@ -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]))
+ src/Table.hs view
@@ -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))