{-# 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)