diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/musicScroll.cabal b/musicScroll.cabal --- a/musicScroll.cabal +++ b/musicScroll.cabal @@ -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 diff --git a/resources/app.glade b/resources/app.glade --- a/resources/app.glade +++ b/resources/app.glade @@ -1,13 +1,10 @@ - + False - - - True False @@ -149,6 +146,18 @@ True + 2 + 0 + + + + + Update + True + True + True + + 1 0 @@ -176,6 +185,9 @@ + + + diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "musicScroll"; - version = "0.3.0.0"; + version = "0.3.1.0"; src = ./.; isLibrary = true; isExecutable = true; diff --git a/src/MusicScroll/DatabaseUtils.hs b/src/MusicScroll/DatabaseUtils.hs --- a/src/MusicScroll/DatabaseUtils.hs +++ b/src/MusicScroll/DatabaseUtils.hs @@ -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" diff --git a/src/MusicScroll/LyricsPipeline.hs b/src/MusicScroll/LyricsPipeline.hs --- a/src/MusicScroll/LyricsPipeline.hs +++ b/src/MusicScroll/LyricsPipeline.hs @@ -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 () diff --git a/src/MusicScroll/Pipeline.hs b/src/MusicScroll/Pipeline.hs --- a/src/MusicScroll/Pipeline.hs +++ b/src/MusicScroll/Pipeline.hs @@ -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 () diff --git a/src/MusicScroll/Providers/AZLyrics.hs b/src/MusicScroll/Providers/AZLyrics.hs --- a/src/MusicScroll/Providers/AZLyrics.hs +++ b/src/MusicScroll/Providers/AZLyrics.hs @@ -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 diff --git a/src/MusicScroll/UI.hs b/src/MusicScroll/UI.hs --- a/src/MusicScroll/UI.hs +++ b/src/MusicScroll/UI.hs @@ -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 diff --git a/src/MusicScroll/UIContext.hs b/src/MusicScroll/UIContext.hs --- a/src/MusicScroll/UIContext.hs +++ b/src/MusicScroll/UIContext.hs @@ -21,6 +21,7 @@ , titleSuplementEntry :: Gtk.Entry , artistSuplementEntry :: Gtk.Entry , suplementAcceptButton :: Gtk.Button + , suplementUpdateButton :: Gtk.Button , keepArtistNameCheck :: Gtk.CheckButton }