module Data.Memo.Sqlite
(
Table()
, table
, Sqlite(..)
, Wrap
, Unwrap
, Wrapper
, ReadShow()
, readShow
, Memo
, MemoRec
, MkMemo
, MkMemoRec
, memo
, memoRec
, memo'
, memoRec'
, SQLData(..)
) where
import Prelude hiding (lookup)
import Control.Monad.Instances ()
import Data.List (isPrefixOf)
import System.IO (fixIO)
import Database.SQLite3
newtype Table = Table String deriving (Eq, Ord, Show)
table :: String -> Maybe Table
table [] = Nothing
table s@(c:_)
| c `elem` letters &&
all (`elem` alphaNum) s &&
not ("sqlite_" `isPrefixOf` s) = Just (Table $ "\"" ++ s ++ "\"")
| otherwise = Nothing
where
letters = ['a'..'z'] ++ ['A'..'Z']
digits = ['0'..'9']
alphaNum = letters ++ digits ++ "_"
class Sqlite t where
toSqlite :: t -> SQLData
fromSqlite :: SQLData -> t
type Wrap s t k v = (k -> IO v) -> s k -> IO (t v)
type Unwrap s t k v = (s k -> IO (t v)) -> k -> IO v
type Wrapper s t k v = (Wrap s t k v, Unwrap s t k v)
newtype ReadShow t = ReadShow{ unReadShow :: t }
instance (Read t, Show t) => Sqlite (ReadShow t) where
toSqlite (ReadShow t) = SQLText (show t)
fromSqlite (SQLText s) = ReadShow $ read s
toReadShow :: Wrap ReadShow ReadShow k v
toReadShow f k = ReadShow `fmap` f (unReadShow k)
fromReadShow :: Unwrap ReadShow ReadShow k v
fromReadShow f k = unReadShow `fmap` f (ReadShow k)
readShow :: Wrapper ReadShow ReadShow k v
readShow = (toReadShow, fromReadShow)
type Memo k v = (k -> IO v) -> IO (IO (), k -> IO v)
type MemoRec k v = ((k -> IO v) -> k -> IO v) -> IO (IO (), k -> IO v)
type MkMemo k v = FilePath -> Table -> Memo k v
type MkMemoRec k v = FilePath -> Table -> MemoRec k v
memo :: (Sqlite k, Sqlite v) => MkMemo k v
memo file (Table tab) f = do
db <- open file
create <- prepare db $ "CREATE TABLE IF NOT EXISTS " ++ tab ++ " ( k TEXT PRIMARY KEY, v TEXT )"
_ <- step create
finalize create
lookup <- prepare db $ "SELECT v FROM " ++ tab ++ " WHERE k = ? LIMIT 1"
insert <- prepare db $ "INSERT INTO " ++ tab ++ " ( k , v ) VALUES ( ? , ? )"
let
cleanup = do
finalize lookup
finalize insert
close db
remember k = do
let ks = toSqlite k
reset lookup
bind lookup [ks]
r <- step lookup
case r of
Row -> do
vs <- column lookup 0
return (fromSqlite vs)
Done -> do
v <- f k
let vs = toSqlite v
reset insert
bind insert [ks, vs]
_ <- step insert
return v
return ( cleanup , remember )
memoRec :: (Sqlite k, Sqlite v) => MkMemoRec k v
memoRec file tab f = fixIO $ \rf -> memo file tab $ f (snd rf)
memo' :: (Sqlite (s k), Sqlite (t v)) => Wrapper s t k v -> MkMemo k v
memo' (wrap, unwrap) file tab = via wrap unwrap (memo file tab)
via i o a f = fmap o `fmap` a (i f)
memoRec' :: (Sqlite (s k), Sqlite (t v)) => Wrapper s t k v -> MkMemoRec k v
memoRec' (wrap, unwrap) file tab = viaRec wrap unwrap (memoRec file tab)
viaRec i o a f = fmap o `fmap` a (i . f . o)