Homework db

Adapter.hs

module Adapter where

import qualified Data.Map as Map

_create :: Ord k => k -> v -> Map k v -> Map k v
_create = Map.insert

_update :: Ord k => k -> v -> Map k v -> Map k v
_update = Map.insert

_read   :: Ord k => k -> Map k v -> Maybe v
_read   = Map.lookup

_delete :: Ord k => k -> Map k v -> Map k v
_delete = Map.delete

_keys   :: Ord k => Map k v -> [k]
_keys   = Map.keys

_merge  :: Ord k => Map k v -> Map k v -> Map k v
_merge  = Map.union

_empty  :: Ord k => Map k v
_empty  = Map.empty

_dump   :: Ord k => Map k v -> [(k, v)]
_dump   = Map.toList

type Map = Map.Map

type Kv = Map

Client.hs

module Client where

data Action =
     Created Key
   | Updated Key
   | Got     Key Value
   | No      Key
   | Read    Filename
   | Written Filename
   | Deleted Key
   | Keys   [Key]
   | Dump    Text
   | Falture Err
   | What

type Key      = String
type Value    = String
type Filename = String
type Err      = String
type Text     = String

data Client =
     Client { intro   :: IO ()
            , request :: IO String
            , inform  :: Action -> IO () }

client =
  Client {
    intro =
      do putStrLn ""
         putStr   "> "

  , request =
      do getLine

  , inform =
      \action -> tell $ 
        case action of 
          Created key -> [key, " was created."]
          Updated key -> [key, " was updated."]
          Read    fdb -> ["DB is read from ", fdb, "."]
          Written fdb -> ["DB is written to ", fdb, "."]
          Got     k v -> [k, ": ", v]
          No      key -> ["key not found: ", key, "."]
          Deleted key -> [key, " was deleted."]
          Keys    kz  -> ["keys: ", show kz]
          Dump    txt -> [txt]
          Falture err -> ["Falture - ", err]
          What        -> ["What?"]
  }

tell rope = putStrLn $ concat ("# " : rope)

DB.hs

import Control.Monad (when)

import System.IO

import Adapter
import Client

repl db client =
  do intro client

     input <- request client

     let operate =
           case words input of
             [] ->
               return db

             "write" : [] ->
               do writeDB "db.txt"

             "write" : filename : [] ->
               do writeDB filename

             "read" : [] ->
               do readDB "db.txt"

             "read" : filename : [] ->
               do readDB filename

             "add" : key : args ->
               do inform client $ Created key

                  return $ _create key args db

             "get" : key : [] ->
               do let value = _read key db
                  let dump  = show `fmap` value

                  inform client $
                    maybe 
                      (No key)
                      (Got key)
                      dump

                  return db

             "dump" : "keys" : [] ->
               do inform client $ Keys $ _keys db

                  return db

             "dump" : "full" : [] ->
               do inform client $ Dump $ show (_dump db)

                  return db

             _ ->
               do inform client $ What

                  return db

     when (input /= "exit") $
      do new_db <- operate
         
         repl new_db client

  where
    complain = inform client . Falture . show

    writeDB filename =
      let unsafeWrite =
            do writeFile filename (show db)

               inform client $ Written filename

               return db

      in do unsafeWrite `catch`
              \err -> do complain err
                         return db

    readDB filename =
      let unsafeRead = 
            do text   <- readFile filename
               new_db <- readIO   text

               inform client $ Read filename

               return $ _merge new_db db

      in do unsafeRead `catch`
              \err -> do complain err
                         return _empty

main = do hSetBuffering stdout NoBuffering
          repl _empty client