hsqml-demo-notes 0.3.2.0 → 0.3.3.0
raw patch · 3 files changed
+252/−3 lines, 3 filesdep +containersdep +transformersnew-component:exe:hsqml-notes-slow
Dependencies added: containers, transformers
Files
- CHANGELOG +10/−0
- hsqml-demo-notes.cabal +16/−3
- src/NotesFast.hs +226/−0
+ CHANGELOG view
@@ -0,0 +1,10 @@+HsQML Samples - Release History++release-0.3.3.0 - 2015.06.17++ * Added faster multi-threaded version of the demo.+ * Renamed original version hsqml-notes-slow.++release-0.3.2.0 - 2014.11.29++ * Initial release.
hsqml-demo-notes.cabal view
@@ -1,10 +1,10 @@ Name: hsqml-demo-notes-Version: 0.3.2.0+Version: 0.3.3.0 Cabal-version: >= 1.10 Build-type: Simple License: BSD3 License-file: LICENSE-Copyright: (c) 2014 Robin KAY+Copyright: (c) 2014-2015 Robin KAY Author: Robin KAY Maintainer: komadori@gekkou.co.uk Stability: experimental@@ -14,11 +14,24 @@ Data-dir: qml Data-files: *.qml *.png Extra-source-files:- README+ README CHANGELOG Description: Sticky notes example program implemented in HsQML Executable hsqml-notes+ Default-language: Haskell2010+ Hs-source-dirs: src+ Main-is: NotesFast.hs+ Build-depends:+ base == 4.*,+ containers >= 0.4 && < 0.6,+ text >= 0.11 && < 1.3,+ transformers >= 0.2 && < 0.5,+ sqlite-simple >= 0.4.8 && < 0.5,+ hsqml >= 0.3.2.1 && < 0.4+ GHC-options: -threaded++Executable hsqml-notes-slow Default-language: Haskell2010 Hs-source-dirs: src Main-is: NotesSlow.hs
+ src/NotesFast.hs view
@@ -0,0 +1,226 @@+{-# 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