packages feed

musicScroll 0.3.2.1 → 0.3.3

raw patch · 19 files changed

+543/−416 lines, 19 files

Files

musicScroll.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/  name:                musicScroll-version:             0.3.2.1+version:             0.3.3 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@@ -30,8 +30,6 @@  library   default-language:    Haskell2010-  ghc-options:         -optl-fuse-ld=gold-  ld-options:          -fuse-ld=gold   hs-source-dirs:      src   build-depends:       base <4.15,                        containers,@@ -56,7 +54,7 @@                        pipes-concurrency,                        contravariant   exposed-modules:     MusicScroll.RealMain-  other-modules:       MusicScroll.UI+                       MusicScroll.UI                        MusicScroll.MPRIS                        MusicScroll.Web                        MusicScroll.LyricsPipeline@@ -72,7 +70,7 @@                        MusicScroll.Providers.AZLyrics                        MusicScroll.Providers.MusiXMatch                        MusicScroll.Providers.Utils-                       Paths_musicScroll+  other-modules:       Paths_musicScroll  -- test-suite playground --     type:       exitcode-stdio-1.0@@ -90,5 +88,4 @@   hs-source-dirs:      app   default-language:    Haskell2010   pkgconfig-depends:   gtk+-3.0-  ghc-options: -Wall -rtsopts -threaded -optl-fuse-ld=gold-  ld-options: -fuse-ld=gold+  ghc-options: -Wall -rtsopts -threaded
shell.nix view
@@ -7,7 +7,7 @@   f = { mkDerivation, async, base, bytestring, containers       , cryptonite, dbus, directory, gi-gtk, gi-gtk-hs, gtk3, mtl, req       , sqlite-simple, stdenv, stm, tagsoup, text, transformers-      , xdg-basedir, pipes, pipes-concurrency+      , xdg-basedir, pipes, pipes-concurrency, haskell-language-server       }:       mkDerivation {         pname = "musicScroll";@@ -19,7 +19,7 @@         libraryHaskellDepends = [           async base bytestring containers cryptonite dbus directory gi-gtk           gi-gtk-hs mtl req sqlite-simple stm tagsoup text transformers-          xdg-basedir pipes pipes-concurrency+          xdg-basedir pipes pipes-concurrency haskell-language-server         ];         executableHaskellDepends = [ base ];         executablePkgconfigDepends = [ gtk3 ];
src/MusicScroll/ConnState.hs view
@@ -5,8 +5,8 @@ import MusicScroll.DBusNames  data ConnState = ConnState-  { cpClient        :: Client-  , cpBusActive     :: BusName+  { cpClient :: Client,+    cpBusActive :: BusName   }  newConnState :: Client -> ConnState
src/MusicScroll/DBusNames.hs view
@@ -1,12 +1,13 @@-{-# language OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+ module MusicScroll.DBusNames where -import DBus (BusName, ObjectPath, InterfaceName)+import DBus (BusName, InterfaceName, ObjectPath)  smplayerBus, vlcBus, dbusBus :: BusName smplayerBus = "org.mpris.MediaPlayer2.smplayer"-vlcBus      = "org.mpris.MediaPlayer2.vlc"-dbusBus     = "org.freedesktop.DBus"+vlcBus = "org.mpris.MediaPlayer2.vlc"+dbusBus = "org.freedesktop.DBus"  -- TODO: Add more! allBuses :: [BusName]
src/MusicScroll/DBusSignals.hs view
@@ -1,62 +1,73 @@-{-# language OverloadedStrings, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module MusicScroll.DBusSignals-  ( mediaPropChangeRule-  , waitForChange-  , changeMusicClient-  ) where+  ( mediaPropChangeRule,+    waitForChange,+    changeMusicClient,+  )+where  import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TMVar (TMVar, takeTMVar, newEmptyTMVar, putTMVar)-import Control.Monad.State.Class (MonadState(..))+import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, putTMVar, takeTMVar)+import Control.Monad.State.Class (MonadState (..))+import DBus+import DBus.Client import Data.Foldable (find) import Data.Maybe (fromJust)-import Pipes--import DBus.Client-import DBus--import MusicScroll.DBusNames import MusicScroll.ConnState+import MusicScroll.DBusNames+import Pipes  mediaPropChangeRule, busNameAddedRule :: MatchRule-mediaPropChangeRule = matchAny-  { matchPath      = pure mediaObject-  , matchInterface = pure "org.freedesktop.DBus.Properties"-  , matchMember    = pure "PropertiesChanged" }-busNameAddedRule = matchAny-  { matchSender    = pure dbusBus -- unique name-  , matchPath      = pure "/org/freedesktop/DBus"-  , matchInterface = pure "org.freedesktop.DBus"-  , matchMember    = pure "NameOwnerChanged" }+mediaPropChangeRule =+  matchAny+    { matchPath = pure mediaObject,+      matchInterface = pure "org.freedesktop.DBus.Properties",+      matchMember = pure "PropertiesChanged"+    }+busNameAddedRule =+  matchAny+    { matchSender = pure dbusBus, -- unique name+      matchPath = pure "/org/freedesktop/DBus",+      matchInterface = pure "org.freedesktop.DBus",+      matchMember = pure "NameOwnerChanged"+    }  waitForChange :: (MonadState ConnState m, MonadIO m) => MatchRule -> m () waitForChange rule = do   (ConnState client _) <- get-  liftIO $ do trigger       <- atomically newEmptyTMVar-              disarmHandler <- armSignal client trigger rule-              _ <- atomically $ takeTMVar trigger-              removeMatch client disarmHandler+  liftIO $ do+    trigger <- atomically newEmptyTMVar+    disarmHandler <- armSignal client trigger rule+    _ <- atomically $ takeTMVar trigger+    removeMatch client disarmHandler  armSignal :: Client -> TMVar () -> MatchRule -> IO SignalHandler armSignal client trigger rule =-  addMatch client rule (\_ -> atomically ( putTMVar trigger () ))+  addMatch client rule (\_ -> atomically (putTMVar trigger ()))  changeMusicClient :: (MonadState ConnState m, MonadIO m) => m () changeMusicClient =-  do (ConnState client _) <- get-     availableStatus <- liftIO $ traverse (checkName client) allBuses-     let taggedBuses = zip allBuses availableStatus-     case fst <$> find snd taggedBuses of-       Just newBus -> put (ConnState client newBus)-       Nothing     -> do waitForChange busNameAddedRule-                         changeMusicClient+  do+    (ConnState client _) <- get+    availableStatus <- liftIO $ traverse (checkName client) allBuses+    let taggedBuses = zip allBuses availableStatus+    case fst <$> find snd taggedBuses of+      Just newBus -> put (ConnState client newBus)+      Nothing -> do+        waitForChange busNameAddedRule+        changeMusicClient  checkName :: Client -> BusName -> IO Bool checkName client name = do-  returnCall <- call_ client+  returnCall <-+    call_+      client       (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "NameHasOwner")-        { methodCallDestination = Just dbusBus-        , methodCallBody = [toVariant name] }+        { methodCallDestination = Just dbusBus,+          methodCallBody = [toVariant name]+        }   -- We assume this call is correct, as it's done to the master dbus   -- object. So fromJust/head are safe.   return . fromJust . fromVariant . head . methodReturnBody $ returnCall
src/MusicScroll/DatabaseUtils.hs view
@@ -1,78 +1,92 @@-{-# language OverloadedStrings, TypeApplications, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+ module MusicScroll.DatabaseUtils-  ( getDBLyrics-  , getDBSong-  , sqlDBCreate-  , InsertStategy-  , insertStrat-  , updateStrat-  , getDBPath-  ) where+  ( getDBLyrics,+    getDBSong,+    sqlDBCreate,+    InsertStategy,+    insertStrat,+    updateStrat,+    getDBPath,+  )+where -import Prelude hiding (null)-import Control.Applicative (Alternative(..))-import Control.Exception (evaluate)-import Control.Monad.Trans.Reader (ReaderT, ask)-import Control.Monad.IO.Class (MonadIO(..))+import Control.Applicative (Alternative (..)) import Control.Concurrent.MVar import Control.DeepSeq (rnf)-import Crypto.Hash (SHA1, hashUpdate, hashInit, hashFinalize)+import Control.Exception (evaluate)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Reader (ReaderT, ask)+import Crypto.Hash (SHA1, hashFinalize, hashInit, hashUpdate) import Data.ByteString (hGet, null)-import System.IO (withFile, IOMode(..))+import Data.Coerce import Data.Text (Text) import Database.SQLite.Simple-import System.Environment.XDG.BaseDir (getUserCacheDir)-import Data.Coerce+import MusicScroll.Providers.Utils (Lyrics (..))+import MusicScroll.TrackInfo (SongFilePath, TrackInfo (..)) import System.Directory (createDirectory)--import MusicScroll.TrackInfo (TrackInfo(..), SongFilePath)-import MusicScroll.Providers.Utils (Lyrics(..))+import System.Environment.XDG.BaseDir (getUserCacheDir)+import System.IO (IOMode (..), withFile)+import Prelude hiding (null)  getDBLyrics :: SongFilePath -> ReaderT (MVar Connection) IO Lyrics getDBLyrics songUrl = snd <$> getDBSong songUrl  getDBSong :: SongFilePath -> ReaderT (MVar Connection) IO (TrackInfo, Lyrics)-getDBSong songUrl = ask >>= \mconn -> liftIO $-  do songHash <- fileHash songUrl-     songRaw <- withMVar mconn-                   (\conn -> query conn sqlExtractSong (Only songHash))-     case (songRaw :: [ (Text, Text, Text) ]) of-       [] -> empty-       (title, artist, lyrics):_ ->-         let track = TrackInfo title artist songUrl-         in pure (track, coerce lyrics)+getDBSong songUrl =+  ask >>= \mconn -> liftIO $+    do+      songHash <- fileHash songUrl+      songRaw <-+        withMVar+          mconn+          (\conn -> query conn sqlExtractSong (Only songHash))+      case (songRaw :: [(Text, Text, Text)]) of+        [] -> empty+        (title, artist, lyrics) : _ ->+          let track = TrackInfo title artist songUrl+           in pure (track, coerce lyrics)  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+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  updateStrat :: InsertStategy-updateStrat (TrackInfo {..}) lyrics = ask >>= \mconn -> liftIO $-  do songHash <- fileHash tUrl-     let params = (coerce lyrics :: Text, songHash)-     withMVar mconn $ \conn -> execute conn sqlUpdateSong params+updateStrat (TrackInfo {..}) lyrics =+  ask >>= \mconn -> liftIO $+    do+      songHash <- fileHash tUrl+      let params = (coerce lyrics :: Text, songHash)+      withMVar mconn $ \conn -> execute conn sqlUpdateSong params  getDBPath :: IO FilePath-getDBPath = do cacheDir <- getUserCacheDir "musicScroll"-               createDirectory cacheDir <|> return ()-               return $ cacheDir ++ "/" ++ "lyrics.db"+getDBPath = do+  cacheDir <- getUserCacheDir "musicScroll"+  createDirectory cacheDir <|> return ()+  return $ cacheDir ++ "/" ++ "lyrics.db"  -- | We use the exception thrown by withFile. fileHash :: FilePath -> IO String fileHash fp = withFile fp ReadMode $ \hdl ->   let chunkSize = 512 * 1024       looper ctx =-          do upd <- hGet hdl chunkSize-             if null upd-               then return (show (hashFinalize ctx))-               else do let newCtx = hashUpdate ctx upd-                       evaluate (rnf newCtx) -- Important!-                       looper newCtx-  in looper (hashInit @SHA1)+        do+          upd <- hGet hdl chunkSize+          if null upd+            then return (show (hashFinalize ctx))+            else do+              let newCtx = hashUpdate ctx upd+              evaluate (rnf newCtx) -- Important!+              looper newCtx+   in looper (hashInit @SHA1)  sqlDBCreate, sqlInsertSong, sqlExtractSong, sqlUpdateSong :: Query sqlDBCreate =@@ -81,11 +95,8 @@   \  artist text,\n\   \  title text, \n\   \  lyrics text );"- sqlInsertSong = "insert into MusicScrollTable values (?, ?, ?, ?);"- sqlExtractSong =   "select title, artist, lyrics from MusicScrollTable where songHash == ?;"- sqlUpdateSong =   "update MusicScrollTable set lyrics = ? where songHash = ? ;"
src/MusicScroll/EventLoop.hs view
@@ -3,21 +3,22 @@ import Control.Concurrent.Async import Control.Concurrent.STM import Data.Foldable (traverse_)- import MusicScroll.Pipeline  -- | This callbacks ought to update the UI themselves via postGUI type UICallback = AppState -> IO ()  data EventLoopState = EventLoopState-  { evAppState    :: AppState-  , evUiCallbacks :: TBQueue UICallback-  , evEphemeral   :: Maybe (Async ()) }+  { evAppState :: AppState,+    evUiCallbacks :: TBQueue UICallback,+    evEphemeral :: Maybe (Async ())+  }  eventLoop :: EventLoopState -> IO a eventLoop st =-  do newCallback <- atomically . readTBQueue $ evUiCallbacks st-     traverse_ cancel (evEphemeral st)-     newAsync <- async (newCallback (evAppState st))-     let st' = st { evEphemeral = Just newAsync }-     eventLoop st'+  do+    newCallback <- atomically . readTBQueue $ evUiCallbacks st+    traverse_ cancel (evEphemeral st)+    newAsync <- async (newCallback (evAppState st))+    let st' = st {evEphemeral = Just newAsync}+    eventLoop st'
src/MusicScroll/LyricsPipeline.hs view
@@ -1,52 +1,56 @@ module MusicScroll.LyricsPipeline-  ( SongByOrigin(..)-  , SearchResult(..)-  , ErrorCause(..)-  , noRepeatedSongs-  , getLyricsFromAnywhere-  , getLyricsOnlyFromWeb-  , saveOnDb-  ) where+  ( SongByOrigin (..),+    SearchResult (..),+    ErrorCause (..),+    noRepeatedSongs,+    getLyricsFromAnywhere,+    getLyricsOnlyFromWeb,+    saveOnDb,+  )+where --- | Discriminate between getting the lyrics from SQLite or the web.+--- | Discriminate between getting the lyrics from SQLite or the web. +import Control.Applicative (Alternative (..)) import Control.Concurrent.MVar-import Control.Applicative (Alternative(..)) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Database.SQLite.Simple-import Pipes-import qualified Pipes.Prelude as PP- import MusicScroll.DatabaseUtils-import MusicScroll.TrackInfo-import MusicScroll.Web-import MusicScroll.Providers.Utils (Lyrics(..)) import MusicScroll.Providers.AZLyrics (azLyricsInstance) import MusicScroll.Providers.MusiXMatch (musiXMatchInstance)+import MusicScroll.Providers.Utils (Lyrics (..))+import MusicScroll.TrackInfo+import MusicScroll.Web+import Pipes+import qualified Pipes.Prelude as PP  data SongByOrigin = DB | Web deriving (Show) -data SearchResult = GotLyric SongByOrigin TrackInfo Lyrics-                  | ErrorOn ErrorCause+data SearchResult+  = GotLyric SongByOrigin TrackInfo Lyrics+  | ErrorOn ErrorCause   deriving (Show)  data ErrorCause = NotOnDB TrackByPath | NoLyricsOnWeb TrackInfo | ENoSong   deriving (Show)  noRepeatedSongs :: Functor m => Pipe TrackIdentifier TrackIdentifier m a-noRepeatedSongs = do firstSong <- await-                     yield firstSong-                     loop firstSong+noRepeatedSongs = do+  firstSong <- await+  yield firstSong+  loop firstSong   where-    loop prevSong = do newSong <- await-                       if (TIWE newSong) /= (TIWE prevSong)-                         then yield newSong *> loop newSong-                         else loop prevSong+    loop prevSong = do+      newSong <- await+      if (TIWE newSong) /= (TIWE prevSong)+        then yield newSong *> loop newSong+        else loop prevSong  getLyricsFromAnywhere :: MVar Connection -> Pipe TrackIdentifier SearchResult IO a getLyricsFromAnywhere connMvar = PP.mapM go-  where go :: TrackIdentifier -> IO SearchResult-        go ident = runReaderT (either caseByPath caseByInfoGeneral ident) connMvar+  where+    go :: TrackIdentifier -> IO SearchResult+    go ident = runReaderT (either caseByPath caseByInfoGeneral ident) connMvar  getLyricsOnlyFromWeb :: Pipe TrackInfo SearchResult IO a getLyricsOnlyFromWeb = PP.mapM caseByInfoWeb@@ -56,20 +60,23 @@   let local = uncurry (GotLyric DB) <$> getDBSong (tUrl track)       web = caseByInfoWeb track       err = pure (ErrorOn (NoLyricsOnWeb track))-  in local <|> web <|> err+   in local <|> web <|> err  caseByInfoWeb :: (MonadIO m, Alternative m) => TrackInfo -> m SearchResult-caseByInfoWeb track = GotLyric Web track <$>-  (getLyricsFromWeb azLyricsInstance track-   <|> getLyricsFromWeb musiXMatchInstance track)+caseByInfoWeb track =+  GotLyric Web track+    <$> ( getLyricsFromWeb azLyricsInstance track+            <|> getLyricsFromWeb musiXMatchInstance track+        )  caseByPath :: TrackByPath -> ReaderT (MVar Connection) IO SearchResult caseByPath track =-  ((uncurry (GotLyric DB)) <$> getDBSong (tpPath track)) <|>-  pure (ErrorOn (NotOnDB track))+  ((uncurry (GotLyric DB)) <$> getDBSong (tpPath track))+    <|> pure (ErrorOn (NotOnDB track))  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 (strat info lyr) mconn-        go _otherwise = pure ()+  where+    go :: SearchResult -> IO ()+    go (GotLyric Web info lyr) = runReaderT (strat info lyr) mconn+    go _otherwise = pure ()
src/MusicScroll/MPRIS.hs view
@@ -1,28 +1,35 @@-{-# language LambdaCase #-}+{-# LANGUAGE LambdaCase #-}+ module MusicScroll.MPRIS (dbusThread) where  import Control.Exception (bracket) import Control.Monad (forever) import Control.Monad.Trans.State (StateT, evalStateT) import DBus.Client-import Pipes as P-import Pipes.Concurrent--import MusicScroll.TrackInfo-import MusicScroll.DBusSignals import MusicScroll.ConnState+import MusicScroll.DBusSignals import MusicScroll.LyricsPipeline+import MusicScroll.TrackInfo+import Pipes as P+import Pipes.Concurrent  dbusThread :: Output TrackIdentifier -> Output ErrorCause -> IO a-dbusThread trackout errorout = bracket connectSession disconnect-  (evalStateT loop . newConnState)+dbusThread trackout errorout =+  bracket+    connectSession+    disconnect+    (evalStateT loop . newConnState)   where     loop :: StateT ConnState IO a-    loop = forever $ tryGetInfo >>= \case-        Left (NoMusicClient _) -> changeMusicClient-        Left NoSong ->-          do runEffect $ yield ENoSong >-> toOutput errorout-             waitForChange mediaPropChangeRule-        Right trackIdent ->-          do runEffect $ yield trackIdent >-> toOutput trackout-             waitForChange mediaPropChangeRule+    loop =+      forever $+        tryGetInfo >>= \case+          Left (NoMusicClient _) -> changeMusicClient+          Left NoSong ->+            do+              runEffect $ yield ENoSong >-> toOutput errorout+              waitForChange mediaPropChangeRule+          Right trackIdent ->+            do+              runEffect $ yield trackIdent >-> toOutput trackout+              waitForChange mediaPropChangeRule
src/MusicScroll/Pipeline.hs view
@@ -1,69 +1,82 @@-{-# language PatternSynonyms #-}+{-# LANGUAGE PatternSynonyms #-}+ module MusicScroll.Pipeline where -import Data.Foldable (traverse_) import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Concurrent.STM.TVar (TVar)-import Database.SQLite.Simple-import Pipes.Concurrent-import Pipes-import qualified Pipes.Prelude as PP+import Data.Foldable (traverse_) import Data.Functor.Contravariant.Divisible--import MusicScroll.LyricsPipeline-import MusicScroll.UIContext (UIContext(..), dischargeOnUI, dischargeOnUISingle)-import MusicScroll.TrackInfo (TrackIdentifier, cleanTrack,-                              pattern OnlyMissingArtist)+import Database.SQLite.Simple import MusicScroll.DatabaseUtils (insertStrat, updateStrat)+import MusicScroll.LyricsPipeline+import MusicScroll.TrackInfo+  ( TrackIdentifier,+    cleanTrack,+    pattern OnlyMissingArtist,+  ) import MusicScroll.TrackSuplement+import MusicScroll.UIContext (UIContext (..), dischargeOnUI, dischargeOnUISingle)+import Pipes+import Pipes.Concurrent+import qualified Pipes.Prelude as PP  data DBusSignal = Song TrackIdentifier | Error ErrorCause | NoInfo   deriving (Show)  data AppState = AppState-  { apUI :: UIContext-  , apDB :: MVar Connection -- ^ Enforce mutual exclusion zone-  , apSupl :: TVar (Maybe TrackSuplement)-  , apStaticinput :: (Input TrackIdentifier, Input ErrorCause)-  , apEphemeralInput :: Producer DBusSignal IO () -- ^ Emits only once.+  { apUI :: UIContext,+    -- | Enforce mutual exclusion zone+    apDB :: MVar Connection,+    apSupl :: TVar (Maybe TrackSuplement),+    apStaticinput :: (Input TrackIdentifier, Input ErrorCause),+    -- | Emits only once.+    apEphemeralInput :: Producer DBusSignal IO ()   }  staticPipeline :: AppState -> IO () staticPipeline (AppState ctx db svar (dbusTrack, dbusErr) _) =-  let songP = fromInput dbusTrack >-> addSuplArtist svar >-> noRepeatedSongs-              >-> cleanTrack-      errP  = fromInput dbusErr+  let songP =+        fromInput dbusTrack >-> addSuplArtist svar >-> noRepeatedSongs+          >-> cleanTrack+      errP = fromInput dbusErr       errorPipe = errP >-> PP.map ErrorOn >-> dischargeOnUI ctx-  in withAsync (songPipe db ctx songP) $ \songA ->-       withAsync (runEffect errorPipe) $ \errorA ->-         void $ waitAnyCancel [ songA, errorA ]+   in withAsync (songPipe db ctx songP) $ \songA ->+        withAsync (runEffect errorPipe) $ \errorA ->+          void $ waitAnyCancel [songA, errorA]  songPipe :: MVar Connection -> UIContext -> Producer TrackIdentifier IO () -> IO () songPipe db ctx = PP.foldM go (pure Nothing) (traverse_ cancel)   where     go :: Maybe (Async ()) -> TrackIdentifier -> IO (Maybe (Async ()))     go asyncVar track =-      do traverse_ cancel asyncVar-         let network = yield track >-> getLyricsFromAnywhere db-                 >-> saveOnDb db insertStrat >-> dischargeOnUI ctx-         Just <$> async (runEffect network)+      do+        traverse_ cancel asyncVar+        let network =+              yield track >-> getLyricsFromAnywhere db+                >-> saveOnDb db insertStrat+                >-> dischargeOnUI ctx+        Just <$> async (runEffect network)  suplementPipeline :: TrackSuplement -> AppState -> IO () suplementPipeline supl (AppState ctx db _ _ signal) =-  let justTracks a = case a of { Song track -> Just track ; _ -> Nothing }+  let justTracks a = case a of Song track -> Just track; _ -> Nothing       songP = signal >-> PP.mapFoldable justTracks-      pipeline = songP >-> mergeSuplement supl >-> getLyricsOnlyFromWeb-          >-> saveOnDb db insertStrat >-> dischargeOnUISingle ctx-  in runEffect pipeline+      pipeline =+        songP >-> mergeSuplement supl >-> getLyricsOnlyFromWeb+          >-> 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 }+  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+      pipeline =+        songP >-> mergeSuplement supl >-> getLyricsOnlyFromWeb+          >-> saveOnDb db updateStrat+          >-> dischargeOnUISingle ctx+   in runEffect pipeline  debugPS :: Show a => String -> Pipe a a IO () debugPS tag = PP.chain (\a -> putStr tag *> print a)@@ -75,9 +88,14 @@ -- The last one is special as it's non-work-stealing, so we can pass it to -- multiple listeners and all will receive a signal. But we have to be -- careful of only taking a single value of it, as it basically a `TVar a`.-musicSpawn :: IO ( Input TrackIdentifier, Input ErrorCause-                 , Producer DBusSignal IO ()-                 , Output TrackIdentifier, Output ErrorCause)+musicSpawn ::+  IO+    ( Input TrackIdentifier,+      Input ErrorCause,+      Producer DBusSignal IO (),+      Output TrackIdentifier,+      Output ErrorCause+    ) musicSpawn = do   (protoTrackout, trackin) <- spawn (newest 1)   (protoErrorout, errorin) <- spawn (newest 1)@@ -91,7 +109,9 @@  addSuplArtist :: TVar (Maybe TrackSuplement) -> Pipe TrackIdentifier TrackIdentifier IO a addSuplArtist svar = PP.mapM go-  where go :: TrackIdentifier -> IO TrackIdentifier-        go signal@(Left OnlyMissingArtist) = atomically (readTVar svar) >>=-            pure . maybe signal (flip suplementOnlyArtist signal)-        go other = pure other+  where+    go :: TrackIdentifier -> IO TrackIdentifier+    go signal@(Left OnlyMissingArtist) =+      atomically (readTVar svar)+        >>= pure . maybe signal (flip suplementOnlyArtist signal)+    go other = pure other
src/MusicScroll/Providers/AZLyrics.hs view
@@ -1,21 +1,24 @@-{-# language OverloadedStrings, DataKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+ module MusicScroll.Providers.AZLyrics (azLyricsInstance) where -import Control.Category hiding ((.), id)+import Control.Category hiding (id, (.)) import Data.Maybe (catMaybes)-import Data.Text as T hiding (filter, tail, map, mapAccumL)+import Data.Text as T hiding (filter, map, mapAccumL, tail) import Data.Traversable (mapAccumL)+import MusicScroll.Providers.Utils+import MusicScroll.TrackInfo (TrackInfo (..)) import Network.HTTP.Req import Text.HTML.TagSoup import Text.HTML.TagSoup.Match (tagOpenLit) -import MusicScroll.TrackInfo (TrackInfo(..))-import MusicScroll.Providers.Utils- azLyricsInstance :: Provider-azLyricsInstance = Provider-  { toUrl = toUrl'-  , extractLyricsFromPage = pipeline }+azLyricsInstance =+  Provider+    { toUrl = toUrl',+      extractLyricsFromPage = pipeline+    }  toUrl' :: TrackInfo -> Url 'Https toUrl' track =@@ -24,21 +27,25 @@        quotedArtist = normalize (tArtist track)       quotedSong = normalize (tTitle track) <> ".html"-  in base /: "lyrics" /: quotedArtist /: quotedSong+   in base /: "lyrics" /: quotedArtist /: quotedSong  normalize :: Text -> Text normalize =   let targets :: String       targets = " '_-"-  in T.intercalate mempty . split (`elem` targets) . toLower+   in T.intercalate mempty . split (`elem` targets) . toLower  pipeline :: Text -> Lyrics-pipeline = parseTags >>> mapAccumL discriminate False >>> snd-             >>> catMaybes >>> innerText >>> stripStart >>> Lyrics+pipeline =+  parseTags >>> mapAccumL discriminate False >>> snd+    >>> catMaybes+    >>> innerText+    >>> stripStart+    >>> Lyrics  discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text)) discriminate onDiv@True tag | isTagText tag = (onDiv, pure tag) discriminate onDiv tag-  | tagOpenLit "div" (== []) tag  = (True, Nothing)-  | isTagCloseName "div" tag      = (False, Nothing)-  | otherwise                     = (onDiv, Nothing)+  | tagOpenLit "div" (== []) tag = (True, Nothing)+  | isTagCloseName "div" tag = (False, Nothing)+  | otherwise = (onDiv, Nothing)
src/MusicScroll/Providers/MusiXMatch.hs view
@@ -1,23 +1,27 @@-{-# language OverloadedStrings, DataKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+ module MusicScroll.Providers.MusiXMatch (musiXMatchInstance) where  import Control.Category hiding ((.)) import Data.Maybe (catMaybes)+import qualified Data.Set as Set import Data.Text (Text, replace, toTitle)-import Network.HTTP.Req-import Text.HTML.TagSoup-import Text.HTML.TagSoup.Match (tagOpenLit, anyAttr) import Data.Traversable (mapAccumL)-import qualified Data.Set as Set -- import Data.Text.IO as T (readFile) -import MusicScroll.TrackInfo (TrackInfo(..)) import MusicScroll.Providers.Utils+import MusicScroll.TrackInfo (TrackInfo (..))+import Network.HTTP.Req+import Text.HTML.TagSoup+import Text.HTML.TagSoup.Match (anyAttr, tagOpenLit)  musiXMatchInstance :: Provider-musiXMatchInstance = Provider-  { toUrl = toUrl'-  , extractLyricsFromPage = pipeline }+musiXMatchInstance =+  Provider+    { toUrl = toUrl',+      extractLyricsFromPage = pipeline+    }  toUrl' :: TrackInfo -> Url 'Https toUrl' track =@@ -26,7 +30,7 @@        quotedArtist = normalize (tArtist track)       quotedSong = normalize (tTitle track)-  in base /: "lyrics" /: quotedArtist /: quotedSong+   in base /: "lyrics" /: quotedArtist /: quotedSong  normalize :: Text -> Text normalize = let noSpaces = replace " " "-" in noSpaces . toTitle@@ -38,18 +42,24 @@ --      return (pipeline contents)  pipeline :: Text -> Lyrics-pipeline = parseTags >>> mapAccumL discriminate False-             >>> snd >>> catMaybes >>> innerText >>> Lyrics+pipeline =+  parseTags >>> mapAccumL discriminate False+    >>> snd+    >>> catMaybes+    >>> innerText+    >>> Lyrics  -- discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text)) discriminate onSpan@True tag | isTagText tag = (onSpan, pure tag) discriminate onSpan tag   | tagOpenLit "span" goodClasses tag = (True, Nothing)-  | isTagCloseName "span" tag         = (False, Nothing)-  | otherwise                         = (onSpan, Nothing)+  | isTagCloseName "span" tag = (False, Nothing)+  | otherwise = (onSpan, Nothing)   where     goodClasses = anyAttr (\attr -> Set.member attr spanDiscr)-    spanDiscr = Set.fromList [ ("class", "lyrics__content__ok")-                             , ("class", "lyrics__content__warning") ]-+    spanDiscr =+      Set.fromList+        [ ("class", "lyrics__content__ok"),+          ("class", "lyrics__content__warning")+        ]
src/MusicScroll/Providers/Utils.hs view
@@ -1,4 +1,5 @@-{-# language DataKinds #-}+{-# LANGUAGE DataKinds #-}+ module MusicScroll.Providers.Utils where  import Data.Text (Text)@@ -11,6 +12,6 @@   show _ = "Lyrics"  data Provider = Provider-  { toUrl :: TrackInfo -> Url 'Https-  , extractLyricsFromPage :: Text -> Lyrics+  { toUrl :: TrackInfo -> Url 'Https,+    extractLyricsFromPage :: Text -> Lyrics   }
src/MusicScroll/RealMain.hs view
@@ -1,25 +1,25 @@-{-# language ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module MusicScroll.RealMain (realMain) where -import Control.Concurrent.Async (withAsync, withAsyncBound, waitAnyCancel)+import Control.Concurrent.Async (waitAnyCancel, withAsync, withAsyncBound)+import Control.Concurrent.MVar import Control.Concurrent.STM.TBQueue (newTBQueue)-import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TMVar-import Control.Concurrent.MVar-import Data.Functor (void)+import Control.Concurrent.STM.TVar import Control.Exception (bracket)+import Data.Functor (void) import Database.SQLite.Simple-import Pipes.Concurrent--import MusicScroll.Pipeline+import MusicScroll.DatabaseUtils (getDBPath, sqlDBCreate)+import MusicScroll.EventLoop import MusicScroll.MPRIS+import MusicScroll.Pipeline import MusicScroll.UI-import MusicScroll.EventLoop-import MusicScroll.DatabaseUtils (getDBPath, sqlDBCreate)+import Pipes.Concurrent  realMain :: IO () realMain = do-  appCtxTMvar  <- atomically newEmptyTMVar+  appCtxTMvar <- atomically newEmptyTMVar   suplTVar <- atomically (newTVar Nothing)   uiCallbackTB <- atomically (newTBQueue 5)   withAsyncBound (uiThread appCtxTMvar uiCallbackTB suplTVar) $ \uiA -> do@@ -29,9 +29,9 @@       bracket (open dbPath) close $ \conn -> do         execute_ conn sqlDBCreate         mconn <- newMVar conn-        ctx   <- atomically (takeTMVar appCtxTMvar)+        ctx <- atomically (takeTMVar appCtxTMvar)         let state = AppState ctx mconn suplTVar (trackin, errorin) singleProd         let evState = EventLoopState state uiCallbackTB Nothing         withAsync (staticPipeline state) $ \staticA ->           withAsync (eventLoop evState) $ \evLoopA ->-            void $ waitAnyCancel [ staticA, evLoopA, uiA, dbusA ]+            void $ waitAnyCancel [staticA, evLoopA, uiA, dbusA]
src/MusicScroll/TrackInfo.hs view
@@ -1,37 +1,42 @@-{-# language OverloadedStrings, NamedFieldPuns, FlexibleContexts, PatternSynonyms #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+ module MusicScroll.TrackInfo where -import           Prelude hiding (readFile, lookup)-import           Control.Applicative (Alternative(..))-import           Control.Monad (join)-import           Control.Monad.State.Class (MonadState(..))-import           DBus-import           DBus.Client-import           Data.Bifunctor (first, bimap)-import           Data.Map.Strict (Map, lookup)-import           Data.Text (Text)+import Control.Applicative (Alternative (..))+import Control.Monad (join)+import Control.Monad.State.Class (MonadState (..))+import DBus+import DBus.Client+import Data.Bifunctor (bimap, first)+import Data.Char (isAlpha)+import Data.Map.Strict (Map, lookup)+import Data.Text (Text) import qualified Data.Text as T-import           Data.Char (isAlpha)-import qualified Pipes.Prelude as PP (map)--import           MusicScroll.DBusNames-import           MusicScroll.ConnState-+import MusicScroll.ConnState+import MusicScroll.DBusNames import Pipes+import qualified Pipes.Prelude as PP (map)+import Prelude hiding (lookup, readFile)  data TrackInfo = TrackInfo-  { tTitle  :: Text-  , tArtist :: Text -- xesam:artist is weird-  , tUrl    :: SongFilePath-  } deriving (Show)+  { tTitle :: Text,+    tArtist :: Text, -- xesam:artist is weird+    tUrl :: SongFilePath+  }+  deriving (Show)  data TrackByPath = TrackByPath-  { tpPath :: SongFilePath-  , tpTitle :: Maybe Text -- Best effort-  , tpArtist :: Maybe Text -- Best effort-  } deriving (Show)+  { tpPath :: SongFilePath,+    tpTitle :: Maybe Text, -- Best effort+    tpArtist :: Maybe Text -- Best effort+  }+  deriving (Show)  type SongFilePath = FilePath+ type TrackIdentifier = Either TrackByPath TrackInfo  newtype TrackIdentifierWithEq = TIWE TrackIdentifier@@ -45,21 +50,24 @@ pattern OnlyMissingArtist :: TrackByPath pattern OnlyMissingArtist <- TrackByPath {tpArtist = Nothing, tpTitle = Just _} - data DBusError = NoMusicClient MethodError | NoSong  -- An exception here means that either there is not a music player -- running or what it is running it's not a song. Either way we should -- wait for a change on the dbus connection to try again.-tryGetInfo :: (MonadState ConnState m, MonadIO m) =>+tryGetInfo ::+  (MonadState ConnState m, MonadIO m) =>   m (Either DBusError TrackIdentifier) tryGetInfo = do   (ConnState client busName) <- get   liftIO $ do-    metadata <- (first NoMusicClient) <$> getPropertyValue client-      (methodCall mediaObject mediaInterface "Metadata") {-        methodCallDestination = pure busName-      }+    metadata <-+      (first NoMusicClient)+        <$> getPropertyValue+          client+          (methodCall mediaObject mediaInterface "Metadata")+            { methodCallDestination = pure busName+            }     pure . join $ obtainTrackInfo <$> metadata  obtainTrackInfo :: Map Text Variant -> Either DBusError TrackIdentifier@@ -67,9 +75,9 @@   let lookup' :: IsVariant a => Text -> Maybe a       lookup' name = lookup name metadata >>= fromVariant -      mTitle  = lookup' "xesam:title"+      mTitle = lookup' "xesam:title"       mArtist = xesamArtistFix (lookup' "xesam:artist") (lookup' "xesam:artist")-      mUrl    = vlcFix <$> lookup' "xesam:url"+      mUrl = vlcFix <$> lookup' "xesam:url"        trackInfo :: Maybe TrackInfo       trackInfo = TrackInfo <$> mTitle <*> mArtist <*> mUrl@@ -78,8 +86,8 @@       trackByPath = TrackByPath <$> mUrl <*> pure mTitle <*> pure mArtist        trackIdent :: Maybe TrackIdentifier-      trackIdent =  (Right <$> trackInfo) <|> (Left <$> trackByPath)-  in maybe (Left NoSong) Right trackIdent+      trackIdent = (Right <$> trackInfo) <|> (Left <$> trackByPath)+   in maybe (Left NoSong) Right trackIdent  -- xesam:artist by definition should return a `[Text]`, but in practice -- it returns a `Text`. This function makes it always return `Text`.@@ -92,9 +100,13 @@ cleanTrack = PP.map go   where     go :: TrackIdentifier -> TrackIdentifier-    go = bimap (\byPath -> let newTitle = cleanTitle <$> tpTitle byPath-                           in byPath { tpTitle = newTitle })-               (\track -> track { tTitle = cleanTitle (tTitle track) })+    go =+      bimap+        ( \byPath ->+            let newTitle = cleanTitle <$> tpTitle byPath+             in byPath {tpTitle = newTitle}+        )+        (\track -> track {tTitle = cleanTitle (tTitle track)})  -- | This functions does two main things: --     1. Remove format at the end, ie .mp3, .opus etc.@@ -104,7 +116,7 @@ cleanTitle title0 =   let (title1, format) = first T.init $ T.breakOnEnd "." title0       title2 = if elem format musicFormats then title1 else title0-  in T.dropWhile (not . isAlpha) title2+   in T.dropWhile (not . isAlpha) title2  musicFormats :: [Text] musicFormats = ["mp3", "flac", "ogg", "wav", "acc", "opus", "webm"]
src/MusicScroll/TrackSuplement.hs view
@@ -1,20 +1,33 @@-{-# language PatternSynonyms #-}+{-# LANGUAGE PatternSynonyms #-}+ module MusicScroll.TrackSuplement-  ( tsTitle, tsArtist, tsKeepArtist, TrackSuplement() , trackSuplement-  , suplement, mergeSuplement, suplementOnlyArtist) where+  ( tsTitle,+    tsArtist,+    tsKeepArtist,+    TrackSuplement (),+    trackSuplement,+    suplement,+    mergeSuplement,+    suplementOnlyArtist,+  )+where  import Data.Text+import MusicScroll.TrackInfo+  ( TrackByPath (..),+    TrackIdentifier,+    TrackInfo (..),+    pattern OnlyMissingArtist,+  ) import Pipes (Pipe) import qualified Pipes.Prelude as PP (map) -import MusicScroll.TrackInfo ( TrackInfo(..), TrackByPath(..)-                             , TrackIdentifier, pattern OnlyMissingArtist )- -- | Invariant, always a valid artist text. data TrackSuplement = TrackSuplement-  { tsTitle :: Text-  , tsArtist :: Text-  , tsKeepArtist :: Bool }+  { tsTitle :: Text,+    tsArtist :: Text,+    tsKeepArtist :: Bool+  }  trackSuplement :: Text -> Text -> Bool -> Maybe TrackSuplement trackSuplement title artist keep@@ -25,20 +38,26 @@ suplement supl = either byPath byInfo   where     byPath :: TrackByPath -> TrackInfo-    byPath path = TrackInfo { tTitle  = tsTitle supl-                            , tArtist = tsArtist supl-                            , tUrl    = tpPath path }+    byPath path =+      TrackInfo+        { tTitle = tsTitle supl,+          tArtist = tsArtist supl,+          tUrl = tpPath path+        }      byInfo :: TrackInfo -> TrackInfo-    byInfo info = info { tTitle = tsTitle supl, tArtist = tsArtist supl}+    byInfo info = info {tTitle = tsTitle supl, tArtist = tsArtist supl}  mergeSuplement :: Functor m => TrackSuplement -> Pipe TrackIdentifier TrackInfo m a mergeSuplement = PP.map . suplement  suplementOnlyArtist :: TrackSuplement -> TrackIdentifier -> TrackIdentifier suplementOnlyArtist supl (Left byPath@OnlyMissingArtist) =-  let trackinfo = TrackInfo { tTitle  = maybe mempty id (tpTitle byPath)-                            , tArtist = tsArtist supl-                            , tUrl    = tpPath byPath }-  in Right trackinfo+  let trackinfo =+        TrackInfo+          { tTitle = maybe mempty id (tpTitle byPath),+            tArtist = tsArtist supl,+            tUrl = tpPath byPath+          }+   in Right trackinfo suplementOnlyArtist _ other = other
src/MusicScroll/UI.hs view
@@ -1,46 +1,49 @@-{-# language RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ module MusicScroll.UI (uiThread, getSuplement) where -import           Control.Concurrent.STM (atomically)-import           Control.Concurrent.STM.TBQueue (TBQueue, writeTBQueue)-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 Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TBQueue (TBQueue, writeTBQueue)+import Control.Concurrent.STM.TMVar (TMVar, putTMVar)+import Control.Concurrent.STM.TVar (TVar, writeTVar)+import Data.Foldable (for_)+import Data.GI.Gtk.Threading (setCurrentThreadAsGUIThread)+import Data.Maybe (fromJust)+import Data.Text (pack) import qualified GI.Gtk as Gtk--import           MusicScroll.TrackSuplement-import           MusicScroll.UIContext-import           MusicScroll.Pipeline-import           MusicScroll.EventLoop--import           Paths_musicScroll-+import MusicScroll.EventLoop+import MusicScroll.Pipeline+import MusicScroll.TrackSuplement+import MusicScroll.UIContext+import Paths_musicScroll  -- Remember to use Gtk.init Nothing before calling this. getGtkScene :: IO UIContext getGtkScene = do-  file    <- getDataFileName "app.glade"+  file <- getDataFileName "app.glade"   builder <- Gtk.builderNewFromFile (pack file)   -- We *know* these ids are defined   let getWidget wid id0 =         Gtk.builderGetObject builder id0-          >>= Gtk.castTo wid . fromJust >>= return . fromJust+          >>= Gtk.castTo wid . fromJust+          >>= return . fromJust   UIContext <$> getWidget Gtk.Window "mainWindow"-            <*> getWidget Gtk.Label "titleLabel"-            <*> getWidget Gtk.Label "artistLabel"-            <*> getWidget Gtk.TextView "lyricsTextView"-            <*> getWidget Gtk.Label "errorLabel"-            <*> getWidget Gtk.Entry "titleSuplementEntry"-            <*> getWidget Gtk.Entry "artistSuplementEntry"-            <*> getWidget Gtk.Button "suplementAcceptButton"-            <*> getWidget Gtk.Button "suplementUpdateButton"-            <*> getWidget Gtk.CheckButton "keepArtistNameCheck"+    <*> getWidget Gtk.Label "titleLabel"+    <*> getWidget Gtk.Label "artistLabel"+    <*> getWidget Gtk.TextView "lyricsTextView"+    <*> getWidget Gtk.Label "errorLabel"+    <*> 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-         -> TVar (Maybe TrackSuplement) -> IO ()+uiThread ::+  TMVar UIContext ->+  TBQueue UICallback ->+  TVar (Maybe TrackSuplement) ->+  IO () uiThread ctxMVar outputTB suplTVar = do   setCurrentThreadAsGUIThread   _ <- Gtk.init Nothing@@ -48,20 +51,23 @@   atomically (putTMVar ctxMVar appCtx)   Gtk.labelSetText titleLabel "MusicScroll"   Gtk.widgetShowAll mainWindow-  _ <- Gtk.onButtonClicked suplementAcceptButton $-         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.onButtonClicked suplementAcceptButton $+      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   _ <- Gtk.onWidgetDestroy mainWindow Gtk.mainQuit   Gtk.main@@ -70,7 +76,8 @@     defUpdate c = getSuplement c >>= atomically . writeTVar suplTVar  getSuplement :: UIContext -> IO (Maybe TrackSuplement)-getSuplement (UIContext {..}) = trackSuplement <$>-  Gtk.entryGetText titleSuplementEntry-  <*> Gtk.entryGetText artistSuplementEntry-  <*> Gtk.getToggleButtonActive keepArtistNameCheck+getSuplement (UIContext {..}) =+  trackSuplement+    <$> Gtk.entryGetText titleSuplementEntry+    <*> Gtk.entryGetText artistSuplementEntry+    <*> Gtk.getToggleButtonActive keepArtistNameCheck
src/MusicScroll/UIContext.hs view
@@ -1,38 +1,40 @@-{-# language OverloadedStrings, RecordWildCards, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ module MusicScroll.UIContext where -import           Control.Monad (unless, forever)-import           Data.GI.Gtk.Threading (postGUISync)-import           Data.Maybe (isNothing)-import           Data.Text as T+import Control.Monad (forever, unless)+import Data.GI.Gtk.Threading (postGUISync)+import Data.Maybe (isNothing)+import Data.Text as T import qualified GI.Gtk as Gtk-import           Pipes--import MusicScroll.TrackInfo (TrackInfo(..), TrackByPath(..))-import MusicScroll.Providers.Utils (Lyrics(..)) import MusicScroll.LyricsPipeline+import MusicScroll.Providers.Utils (Lyrics (..))+import MusicScroll.TrackInfo (TrackByPath (..), TrackInfo (..))+import Pipes  data UIContext = UIContext-  { mainWindow     :: Gtk.Window-  , titleLabel     :: Gtk.Label-  , artistLabel    :: Gtk.Label-  , lyricsTextView :: Gtk.TextView-  , errorLabel     :: Gtk.Label-  , titleSuplementEntry   :: Gtk.Entry-  , artistSuplementEntry  :: Gtk.Entry-  , suplementAcceptButton :: Gtk.Button-  , suplementUpdateButton :: Gtk.Button-  , keepArtistNameCheck   :: Gtk.CheckButton+  { mainWindow :: Gtk.Window,+    titleLabel :: Gtk.Label,+    artistLabel :: Gtk.Label,+    lyricsTextView :: Gtk.TextView,+    errorLabel :: Gtk.Label,+    titleSuplementEntry :: Gtk.Entry,+    artistSuplementEntry :: Gtk.Entry,+    suplementAcceptButton :: Gtk.Button,+    suplementUpdateButton :: Gtk.Button,+    keepArtistNameCheck :: Gtk.CheckButton   }  errorMsg :: ErrorCause -> Text errorMsg (NotOnDB trackPath)   | isNothing (tpArtist trackPath) =-        "No lyrics found by hash on the song file, try to suplement the song's\-        \ artist metadata to try to get it from the web."+    "No lyrics found by hash on the song file, try to suplement the song's\+    \ artist metadata to try to get it from the web."   | isNothing (tpTitle trackPath) =-        "No lyrics found by hash on the song file, try to suplement the song's\-        \ title metadata to try to get it from the web."+    "No lyrics found by hash on the song file, try to suplement the song's\+    \ title metadata to try to get it from the web."   | otherwise = "This case should not happen" errorMsg ENoSong = "No song found, this is usually an intermediary state." errorMsg (NoLyricsOnWeb _) = "Lyrics provider didn't have that song."@@ -47,13 +49,13 @@ updateNewLyrics :: UIContext -> (TrackInfo, Lyrics) -> IO () updateNewLyrics ctx@(UIContext {..}) (track, Lyrics singleLyrics) =   let !bytesToUpdate = fromIntegral $ T.length singleLyrics-  in postGUISync $ do-    Gtk.labelSetText errorLabel mempty-    Gtk.labelSetText titleLabel (tTitle track)-    Gtk.labelSetText artistLabel (tArtist track)-    lyricsBuffer <- Gtk.textViewGetBuffer lyricsTextView-    Gtk.textBufferSetText lyricsBuffer singleLyrics bytesToUpdate-    updateSuplementalGuess ctx (mempty, mempty)+   in postGUISync $ do+        Gtk.labelSetText errorLabel mempty+        Gtk.labelSetText titleLabel (tTitle track)+        Gtk.labelSetText artistLabel (tArtist track)+        lyricsBuffer <- Gtk.textViewGetBuffer lyricsTextView+        Gtk.textBufferSetText lyricsBuffer singleLyrics bytesToUpdate+        updateSuplementalGuess ctx (mempty, mempty)  dischargeOnUI :: UIContext -> Consumer SearchResult IO a dischargeOnUI ctx = forever (dischargeOnUISingle ctx)@@ -67,16 +69,18 @@  updateErrorCause :: UIContext -> ErrorCause -> IO () updateErrorCause ctx@(UIContext {..}) cause = postGUISync $-  do Gtk.labelSetText titleLabel "No Song available"-     Gtk.labelSetText artistLabel mempty-     lyricsBuffer <- Gtk.textViewGetBuffer lyricsTextView-     Gtk.textBufferSetText lyricsBuffer mempty 0-     Gtk.labelSetText errorLabel (errorMsg cause)-     maybe (return ()) (updateSuplementalGuess ctx) (extractGuess cause)+  do+    Gtk.labelSetText titleLabel "No Song available"+    Gtk.labelSetText artistLabel mempty+    lyricsBuffer <- Gtk.textViewGetBuffer lyricsTextView+    Gtk.textBufferSetText lyricsBuffer mempty 0+    Gtk.labelSetText errorLabel (errorMsg cause)+    maybe (return ()) (updateSuplementalGuess ctx) (extractGuess cause)  updateSuplementalGuess :: UIContext -> (Text, Text) -> IO () updateSuplementalGuess (UIContext {..}) (guessTitle, guessArtist) =-  do Gtk.entrySetText titleSuplementEntry guessTitle-     shouldMaintainArtistSupl <- Gtk.getToggleButtonActive keepArtistNameCheck-     unless shouldMaintainArtistSupl $-       Gtk.entrySetText artistSuplementEntry guessArtist+  do+    Gtk.entrySetText titleSuplementEntry guessTitle+    shouldMaintainArtistSupl <- Gtk.getToggleButtonActive keepArtistNameCheck+    unless shouldMaintainArtistSupl $+      Gtk.entrySetText artistSuplementEntry guessArtist
src/MusicScroll/Web.hs view
@@ -1,28 +1,40 @@-{-# language RecordWildCards, TypeApplications, DataKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+ module MusicScroll.Web (getLyricsFromWeb) where +import Control.Applicative (Alternative (empty)) import Control.Exception (try)-import Control.Applicative (Alternative(empty))-import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.IO.Class (MonadIO (..)) import Data.Text.Encoding (decodeUtf8)-import Network.HTTP.Req--import MusicScroll.TrackInfo (TrackInfo(..)) import MusicScroll.Providers.Utils+import MusicScroll.TrackInfo (TrackInfo (..))+import Network.HTTP.Req -getLyricsFromWeb :: (MonadIO m, Alternative m) => Provider -> TrackInfo-                  -> m Lyrics+getLyricsFromWeb ::+  (MonadIO m, Alternative m) =>+  Provider ->+  TrackInfo ->+  m Lyrics getLyricsFromWeb (Provider {..}) track =-  do let songUrl = toUrl track-     resp <- liftIO $ try @HttpException (getPage songUrl)-     let notValid = either (const True)-                      ((/= 200) . responseStatusCode) resp-     if notValid then empty-       else let Right realResp = resp-                body   = decodeUtf8 (responseBody realResp)-                lyrics = extractLyricsFromPage body-            in pure lyrics+  do+    let songUrl = toUrl track+    resp <- liftIO $ try @HttpException (getPage songUrl)+    let notValid =+          either+            (const True)+            ((/= 200) . responseStatusCode)+            resp+    if notValid+      then empty+      else+        let Right realResp = resp+            body = decodeUtf8 (responseBody realResp)+            lyrics = extractLyricsFromPage body+         in pure lyrics  getPage :: Url 'Https -> IO BsResponse-getPage url = runReq defaultHttpConfig $-  req GET url NoReqBody bsResponse mempty+getPage url =+  runReq defaultHttpConfig $+    req GET url NoReqBody bsResponse mempty