musicScroll 0.3.0.0 → 0.3.1.0
raw patch · 10 files changed
+67/−29 lines, 10 files
Files
- CHANGELOG.md +5/−0
- musicScroll.cabal +1/−1
- resources/app.glade +16/−4
- shell.nix +1/−1
- src/MusicScroll/DatabaseUtils.hs +12/−10
- src/MusicScroll/LyricsPipeline.hs +3/−3
- src/MusicScroll/Pipeline.hs +11/−2
- src/MusicScroll/Providers/AZLyrics.hs +4/−1
- src/MusicScroll/UI.hs +13/−7
- src/MusicScroll/UIContext.hs +1/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Revision history for music-scroll +# 0.3.1.0++* Add an update button to overwrite lyrics.+* Create better url for the lyrics' providers.+ # 0.3.0.0 * `Pipes` based code.
musicScroll.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: musicScroll-version: 0.3.0.0+version: 0.3.1.0 synopsis: Supply your tunes info without leaving your music player. description: Automatically retrive the lyrics of of your current song on SMPlayer/VLC and update it on each change. See the
resources/app.glade view
@@ -1,13 +1,10 @@ <?xml version="1.0" encoding="UTF-8"?>-<!-- Generated with glade 3.22.1 -->+<!-- Generated with glade 3.36.0 --> <interface> <requires lib="gtk+" version="3.20"/> <object class="GtkWindow" id="mainWindow"> <property name="can_focus">False</property> <child>- <placeholder/>- </child>- <child> <object class="GtkGrid"> <property name="visible">True</property> <property name="can_focus">False</property>@@ -149,6 +146,18 @@ <property name="draw_indicator">True</property> </object> <packing>+ <property name="left_attach">2</property>+ <property name="top_attach">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkButton" id="suplementUpdateButton">+ <property name="label" translatable="yes">Update</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ </object>+ <packing> <property name="left_attach">1</property> <property name="top_attach">0</property> </packing>@@ -176,6 +185,9 @@ </packing> </child> </object>+ </child>+ <child type="titlebar">+ <placeholder/> </child> </object> </interface>
shell.nix view
@@ -11,7 +11,7 @@ }: mkDerivation { pname = "musicScroll";- version = "0.3.0.0";+ version = "0.3.1.0"; src = ./.; isLibrary = true; isExecutable = true;
src/MusicScroll/DatabaseUtils.hs view
@@ -3,7 +3,9 @@ ( getDBLyrics , getDBSong , sqlDBCreate- , insertDBLyrics+ , InsertStategy+ , insertStrat+ , updateStrat , getDBPath ) where @@ -40,19 +42,19 @@ let track = TrackInfo title artist songUrl in pure (track, coerce lyrics) -insertDBLyrics :: TrackInfo -> Lyrics -> ReaderT (MVar Connection) IO ()-insertDBLyrics (TrackInfo {..}) lyrics =- ask >>= \mconn -> liftIO $- do songHash <- fileHash tUrl- let params = (songHash, tArtist, tTitle, coerce lyrics :: Text)- withMVar mconn $ \conn -> execute conn sqlInsertSong params+type InsertStategy = TrackInfo -> Lyrics -> ReaderT (MVar Connection) IO () +insertStrat :: InsertStategy+insertStrat (TrackInfo {..}) lyrics = ask >>= \mconn -> liftIO $+ do songHash <- fileHash tUrl+ let params = (songHash, tArtist, tTitle, coerce lyrics :: Text)+ withMVar mconn $ \conn -> execute conn sqlInsertSong params -updateDBLyrics :: TrackInfo -> Lyrics -> ReaderT Connection IO ()-updateDBLyrics (TrackInfo {..}) lyrics = ask >>= \conn -> liftIO $+updateStrat :: InsertStategy+updateStrat (TrackInfo {..}) lyrics = ask >>= \mconn -> liftIO $ do songHash <- fileHash tUrl let params = (coerce lyrics :: Text, songHash)- execute conn sqlUpdateSong params+ withMVar mconn $ \conn -> execute conn sqlUpdateSong params getDBPath :: IO FilePath getDBPath = do cacheDir <- getUserCacheDir "musicScroll"
src/MusicScroll/LyricsPipeline.hs view
@@ -67,8 +67,8 @@ ((uncurry (GotLyric DB)) <$> getDBSong (tpPath track)) <|> pure (ErrorOn (NotOnDB track)) -saveOnDb :: MVar Connection -> Pipe SearchResult SearchResult IO a-saveOnDb mconn = PP.chain go+saveOnDb :: MVar Connection -> InsertStategy -> Pipe SearchResult SearchResult IO a+saveOnDb mconn strat = PP.chain go where go :: SearchResult -> IO ()- go (GotLyric Web info lyr) = runReaderT (insertDBLyrics info lyr) mconn+ go (GotLyric Web info lyr) = runReaderT (strat info lyr) mconn go _otherwise = pure ()
src/MusicScroll/Pipeline.hs view
@@ -15,6 +15,7 @@ import MusicScroll.UIContext (UIContext(..), dischargeOnUI, dischargeOnUISingle) import MusicScroll.TrackInfo (TrackIdentifier, cleanTrack, pattern OnlyMissingArtist)+import MusicScroll.DatabaseUtils (insertStrat, updateStrat) import MusicScroll.TrackSuplement data DBusSignal = Song TrackIdentifier | Error ErrorCause | NoInfo@@ -45,7 +46,7 @@ go asyncVar track = do traverse_ cancel asyncVar let network = yield track >-> getLyricsFromAnywhere db- >-> saveOnDb db >-> dischargeOnUI ctx+ >-> saveOnDb db insertStrat >-> dischargeOnUI ctx Just <$> async (runEffect network) suplementPipeline :: TrackSuplement -> AppState -> IO ()@@ -53,7 +54,15 @@ let justTracks a = case a of { Song track -> Just track ; _ -> Nothing } songP = signal >-> PP.mapFoldable justTracks pipeline = songP >-> mergeSuplement supl >-> getLyricsOnlyFromWeb- >-> saveOnDb db >-> dischargeOnUISingle ctx+ >-> saveOnDb db insertStrat >-> dischargeOnUISingle ctx+ in runEffect pipeline++updatePipeline :: TrackSuplement -> AppState -> IO ()+updatePipeline supl (AppState ctx db _ _ signal) =+ let justTracks a = case a of { Song track -> Just track ; _ -> Nothing }+ songP = signal >-> PP.mapFoldable justTracks+ pipeline = songP >-> mergeSuplement supl >-> getLyricsOnlyFromWeb+ >-> saveOnDb db updateStrat >-> dischargeOnUISingle ctx in runEffect pipeline debugPS :: Show a => String -> Pipe a a IO ()
src/MusicScroll/Providers/AZLyrics.hs view
@@ -27,7 +27,10 @@ in base /: "lyrics" /: quotedArtist /: quotedSong normalize :: Text -> Text-normalize = let noSpaces = replace " " "" in noSpaces . toLower+normalize =+ let targets :: String+ targets = " '_-"+ in T.intercalate mempty . split (`elem` targets) . toLower pipeline :: Text -> Lyrics pipeline = parseTags >>> mapAccumL discriminate False >>> snd
src/MusicScroll/UI.hs view
@@ -6,6 +6,7 @@ import Control.Concurrent.STM.TMVar (TMVar, putTMVar) import Control.Concurrent.STM.TVar (TVar, writeTVar) import Data.GI.Gtk.Threading (setCurrentThreadAsGUIThread)+import Data.Foldable (for_) import Data.Maybe (fromJust) import Data.Text (pack) import qualified GI.Gtk as Gtk@@ -35,6 +36,7 @@ <*> getWidget Gtk.Entry "titleSuplementEntry" <*> getWidget Gtk.Entry "artistSuplementEntry" <*> getWidget Gtk.Button "suplementAcceptButton"+ <*> getWidget Gtk.Button "suplementUpdateButton" <*> getWidget Gtk.CheckButton "keepArtistNameCheck" uiThread :: TMVar UIContext -> TBQueue UICallback@@ -47,13 +49,17 @@ Gtk.labelSetText titleLabel "MusicScroll" Gtk.widgetShowAll mainWindow _ <- Gtk.onButtonClicked suplementAcceptButton $- do getSuplement appCtx >>= \msupl -> do- case msupl of- Just supl -> do- let callback = suplementPipeline supl- atomically (writeTBQueue outputTB callback)- _ -> pure ()- atomically (writeTVar suplTVar msupl)+ getSuplement appCtx >>= \msupl -> do+ for_ msupl $ \supl ->+ let callback = suplementPipeline supl+ in atomically (writeTBQueue outputTB callback)+ atomically (writeTVar suplTVar msupl)+ _ <- Gtk.onButtonClicked suplementUpdateButton $+ getSuplement appCtx >>= \msupl -> do+ for_ msupl $ \supl ->+ let callback = updatePipeline supl+ in atomically (writeTBQueue outputTB callback)+ atomically (writeTVar suplTVar msupl) _ <- Gtk.afterWidgetFocusOutEvent artistSuplementEntry $ const (defUpdate appCtx *> pure True) _ <- Gtk.afterToggleButtonToggled keepArtistNameCheck $ defUpdate appCtx
src/MusicScroll/UIContext.hs view
@@ -21,6 +21,7 @@ , titleSuplementEntry :: Gtk.Entry , artistSuplementEntry :: Gtk.Entry , suplementAcceptButton :: Gtk.Button+ , suplementUpdateButton :: Gtk.Button , keepArtistNameCheck :: Gtk.CheckButton }