{-# LANGUAGE RankNTypes, DeriveDataTypeable #-}
module Main where
import System.Environment (getArgs)
import Data.Functor.Identity
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Control.Applicative
import Control.Concurrent
import qualified Database.SQLite.Simple as S
import qualified Database.SQLite.Simple.FromField as S
import qualified Database.SQLite.Simple.ToField as S
import Graphics.QML
import Paths_hsqml_demo_notes
newtype Note = Note {noteId :: Int} deriving (Eq, Ord, Typeable)
data DBStatus
= Current
| UpdatePending
| InsertPending
| DeletePending
deriving Eq
data NoteData = NoteData {
noteX :: Int,
noteY :: Int,
noteReverse :: Bool,
noteFront :: Text,
noteBack :: Text,
noteStatus :: DBStatus
}
data DBCommand = Load | Pending | Quit
type ModelVar = MVar (Map Note NoteData)
type CmdVar = MVar DBCommand
type Lens t p = (Functor f) => (p -> f p) -> t -> f t
view :: Lens t p -> t -> p
view ln = getConst . ln Const
set :: Lens t p -> p -> t -> t
set ln val = runIdentity . ln (const $ Identity val)
alter :: Lens t p -> (p -> p) -> t -> t
alter ln fn = runIdentity . ln (\val -> Identity $ fn val)
noteXLens :: Lens NoteData Int
noteXLens fn nd = fmap (\x' -> nd {noteX = x'}) . fn $ noteX nd
noteYLens :: Lens NoteData Int
noteYLens fn nd = fmap (\y' -> nd {noteY = y'}) . fn $ noteY nd
noteReverseLens :: Lens NoteData Bool
noteReverseLens fn nd =
fmap (\rev' -> nd {noteReverse = rev'}) . fn $ noteReverse nd
noteFrontLens :: Lens NoteData Text
noteFrontLens fn nd =
fmap (\front' -> nd {noteFront = front'}) . fn $ noteFront nd
noteBackLens :: Lens NoteData Text
noteBackLens fn nd =
fmap (\back' -> nd {noteBack = back'}) . fn $ noteBack nd
noteStatusLens :: Lens NoteData DBStatus
noteStatusLens fn nd =
fmap (\status' -> nd {noteStatus = status'}) . fn $ noteStatus nd
selectNotes :: ModelVar -> IO [Note]
selectNotes modelVar = withMVar modelVar (
return . Map.keys . Map.filter ((/= DeletePending) . noteStatus))
insertNote :: ModelVar -> Int -> Int -> Text -> IO ()
insertNote modelVar x y front = modifyMVar_ modelVar (\notes ->
let (Note lastId) = fromMaybe (Note 0) . fmap fst . fmap fst $
Map.maxViewWithKey notes
newNote = Note (lastId+1)
in return $ Map.insert newNote (
NoteData x y False front T.empty InsertPending) notes)
deleteNote :: ModelVar -> Note -> IO ()
deleteNote modelVar note = modifyMVar_ modelVar (
return . Map.adjust (set noteStatusLens DeletePending) note)
readNoteAttrib :: ModelVar -> Lens NoteData a -> ObjRef Note -> IO a
readNoteAttrib modelVar attrib note = withMVar modelVar (
return . view attrib .
fromMaybe (NoteData 0 0 False T.empty T.empty Current) .
Map.lookup (fromObjRef note))
writeNoteAttrib ::
ModelVar -> CmdVar -> Lens NoteData a -> SignalKey (IO ()) ->
ObjRef Note -> a -> IO ()
writeNoteAttrib modelVar cmdVar attrib changeKey note value = do
modifyMVar_ modelVar (return . Map.adjust (
set attrib value . alter noteStatusLens updateState) (fromObjRef note))
tryPutMVar cmdVar Pending
fireSignal changeKey note
where updateState InsertPending = InsertPending
updateState DeletePending = DeletePending
updateState _ = UpdatePending
createContext :: ModelVar -> CmdVar -> SignalKey (IO ()) -> IO (ObjRef ())
createContext modelVar cmdVar changeKey = do
noteClass <- newClass [
defPropertySigRW "x" changeKey
(readNoteAttrib modelVar noteXLens)
(writeNoteAttrib modelVar cmdVar noteXLens changeKey),
defPropertySigRW "y" changeKey
(readNoteAttrib modelVar noteYLens)
(writeNoteAttrib modelVar cmdVar noteYLens changeKey),
defPropertySigRW "reverse" changeKey
(readNoteAttrib modelVar noteReverseLens)
(writeNoteAttrib modelVar cmdVar noteReverseLens changeKey),
defPropertySigRW "front" changeKey
(readNoteAttrib modelVar noteFrontLens)
(writeNoteAttrib modelVar cmdVar noteFrontLens changeKey),
defPropertySigRW "back" changeKey
(readNoteAttrib modelVar noteBackLens)
(writeNoteAttrib modelVar cmdVar noteBackLens changeKey)]
notePool <- newFactoryPool (newObject noteClass)
rootClass <- newClass [
defPropertySigRO' "notes" changeKey (\_ -> do
notes <- selectNotes modelVar
mapM (getPoolObject notePool) notes),
defMethod' "insertNote" (\this x y front -> do
insertNote modelVar x y front
tryPutMVar cmdVar Pending
fireSignal changeKey this),
defMethod' "deleteNote" (\this note -> do
deleteNote modelVar $ fromObjRef note
tryPutMVar cmdVar Pending
fireSignal changeKey this)]
newObject rootClass ()
createTableDb :: S.Connection -> IO ()
createTableDb conn =
S.execute_ conn . S.Query . T.pack $
"CREATE TABLE IF NOT EXISTS notes (" ++
"id INTEGER PRIMARY KEY AUTOINCREMENT, " ++
"x INTEGER, y INTEGER, reverse BOOLEAN, front TEXT, back TEXT)"
selectNotesDb :: S.Connection -> a -> (a -> Note -> NoteData -> IO a) -> IO a
selectNotesDb conn zero func =
let query = S.Query $ T.pack
"SELECT id,x,y,reverse,front,back FROM notes ORDER BY id DESC"
in S.fold_ conn query zero (\acc (i,x,y,rev,front,back) ->
func acc (Note i) (NoteData x y rev front back Current))
insertNoteDb :: S.Connection -> Note -> NoteData -> IO ()
insertNoteDb conn note dat =
S.execute conn (S.Query $ T.pack
"INSERT INTO notes (id,x,y,reverse,front,back) VALUES (?,?,?,?,?,?)")
(noteId note, noteX dat, noteY dat,
noteReverse dat, noteFront dat, noteBack dat)
deleteNoteDb :: S.Connection -> Note -> IO ()
deleteNoteDb conn =
let query = S.Query $ T.pack "DELETE FROM notes WHERE id = ?"
in S.execute conn query . S.Only . noteId
updateNoteDb :: S.Connection -> Note -> NoteData -> IO ()
updateNoteDb conn note dat =
S.execute conn (S.Query $ T.pack
"UPDATE notes SET x=?, y=?, reverse=?, front=?, back=? WHERE id=?")
(noteX dat, noteY dat,
noteReverse dat, noteFront dat, noteBack dat, noteId note)
dbThread ::
S.Connection -> ModelVar -> CmdVar -> MVar () -> IO () -> IO ()
dbThread conn modelVar cmdVar finVar changeCb = do
cmd <- takeMVar cmdVar
case cmd of
Load -> do
createTableDb conn
selectNotesDb conn () $ \_ note dat -> do
modifyMVar_ modelVar (return . Map.insert note dat)
changeCb
dbThread conn modelVar cmdVar finVar changeCb
Pending -> do
pending <- modifyMVar modelVar (\notes ->
let pending = Map.toList $
Map.filter ((/= Current) . noteStatus) notes
notes' = Map.mapMaybe (\dat -> case noteStatus dat of
DeletePending -> Nothing
_ -> Just $
set noteStatusLens Current dat) notes
in return (notes', pending))
mapM_ (\(note,dat) -> case noteStatus dat of
DeletePending -> deleteNoteDb conn note
InsertPending -> insertNoteDb conn note dat
UpdatePending -> updateNoteDb conn note dat) pending
dbThread conn modelVar cmdVar finVar changeCb
Quit -> putMVar finVar ()
main :: IO ()
main = do
modelVar <- newMVar Map.empty
cmdVar <- newMVar Load
finVar <- newEmptyMVar
changeKey <- newSignalKey
ctx <- createContext modelVar cmdVar changeKey
forkOS $ S.withConnection "notes.db" $ \conn ->
dbThread conn modelVar cmdVar finVar (fireSignal changeKey ctx)
args <- getArgs
path <- case args of
("local":p:_) -> return $ p ++ ".qml"
(p:_) -> getDataFileName $ p ++ ".qml"
_ -> getDataFileName "notes.qml"
runEngineLoop defaultEngineConfig {
initialDocument = fileDocument path,
contextObject = Just $ anyObjRef ctx}
tryPutMVar cmdVar Quit
takeMVar finVar