{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module MusicScroll.Providers.AZLyrics (azLyricsInstance) where import Control.Category hiding (id, (.)) import Data.Maybe (catMaybes) import Data.Text as T hiding (filter, map, mapAccumL, tail, elem) 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) azLyricsInstance :: Provider azLyricsInstance :: Provider azLyricsInstance = Provider { toUrl :: TrackInfo -> Url 'Https toUrl = TrackInfo -> Url 'Https toUrl', extractLyricsFromPage :: Text -> Lyrics extractLyricsFromPage = Text -> Lyrics pipeline } toUrl' :: TrackInfo -> Url 'Https toUrl' :: TrackInfo -> Url 'Https toUrl' TrackInfo track = let base :: Url 'Https base :: Url 'Https base = Text -> Url 'Https https Text "www.azlyrics.com" quotedArtist :: Text quotedArtist = Text -> Text normalize (TrackInfo -> Text tArtist TrackInfo track) quotedSong :: Text quotedSong = Text -> Text normalize (TrackInfo -> Text tTitle TrackInfo track) Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ".html" in Url 'Https base Url 'Https -> Text -> Url 'Https forall (scheme :: Scheme). Url scheme -> Text -> Url scheme /: Text "lyrics" Url 'Https -> Text -> Url 'Https forall (scheme :: Scheme). Url scheme -> Text -> Url scheme /: Text quotedArtist Url 'Https -> Text -> Url 'Https forall (scheme :: Scheme). Url scheme -> Text -> Url scheme /: Text quotedSong normalize :: Text -> Text normalize :: Text -> Text normalize = let targets :: String targets :: String targets = String " '_-" in Text -> [Text] -> Text T.intercalate Text forall a. Monoid a => a mempty ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . (Char -> Bool) -> Text -> [Text] split (Char -> String -> Bool forall a. Eq a => a -> [a] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` String targets) (Text -> [Text]) -> (Text -> Text) -> Text -> [Text] forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Text toLower pipeline :: Text -> Lyrics pipeline :: Text -> Lyrics pipeline = Text -> [Tag Text] forall str. StringLike str => str -> [Tag str] parseTags (Text -> [Tag Text]) -> ([Tag Text] -> Lyrics) -> Text -> Lyrics forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c >>> (Bool -> Tag Text -> (Bool, Maybe (Tag Text))) -> Bool -> [Tag Text] -> (Bool, [Maybe (Tag Text)]) forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) mapAccumL Bool -> Tag Text -> (Bool, Maybe (Tag Text)) discriminate Bool False ([Tag Text] -> (Bool, [Maybe (Tag Text)])) -> ((Bool, [Maybe (Tag Text)]) -> Lyrics) -> [Tag Text] -> Lyrics forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c >>> (Bool, [Maybe (Tag Text)]) -> [Maybe (Tag Text)] forall a b. (a, b) -> b snd ((Bool, [Maybe (Tag Text)]) -> [Maybe (Tag Text)]) -> ([Maybe (Tag Text)] -> Lyrics) -> (Bool, [Maybe (Tag Text)]) -> Lyrics forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c >>> [Maybe (Tag Text)] -> [Tag Text] forall a. [Maybe a] -> [a] catMaybes ([Maybe (Tag Text)] -> [Tag Text]) -> ([Tag Text] -> Lyrics) -> [Maybe (Tag Text)] -> Lyrics forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c >>> [Tag Text] -> Text forall str. StringLike str => [Tag str] -> str innerText ([Tag Text] -> Text) -> (Text -> Lyrics) -> [Tag Text] -> Lyrics forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c >>> Text -> Text stripStart (Text -> Text) -> (Text -> Lyrics) -> Text -> Lyrics forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k). Category cat => cat a b -> cat b c -> cat a c >>> Text -> Lyrics Lyrics discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text)) discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text)) discriminate onDiv :: Bool onDiv@Bool True Tag Text tag | Tag Text -> Bool forall str. Tag str -> Bool isTagText Tag Text tag = (Bool onDiv, Tag Text -> Maybe (Tag Text) forall a. a -> Maybe a forall (f :: * -> *) a. Applicative f => a -> f a pure Tag Text tag) discriminate Bool onDiv Tag Text tag | Text -> ([Attribute Text] -> Bool) -> Tag Text -> Bool forall str. Eq str => str -> ([Attribute str] -> Bool) -> Tag str -> Bool tagOpenLit Text "div" ([Attribute Text] -> [Attribute Text] -> Bool forall a. Eq a => a -> a -> Bool == []) Tag Text tag = (Bool True, Maybe (Tag Text) forall a. Maybe a Nothing) | Text -> Tag Text -> Bool forall str. Eq str => str -> Tag str -> Bool isTagCloseName Text "div" Tag Text tag = (Bool False, Maybe (Tag Text) forall a. Maybe a Nothing) | Bool otherwise = (Bool onDiv, Maybe (Tag Text) forall a. Maybe a Nothing)