{-# 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 Data.Traversable (mapAccumL)
-- import Data.Text.IO as T (readFile)

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
musiXMatchInstance =
  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.musixmatch.com"

      quotedArtist :: Text
quotedArtist = Text -> Text
normalize (TrackInfo -> Text
tArtist TrackInfo
track)
      quotedSong :: Text
quotedSong = Text -> Text
normalize (TrackInfo -> Text
tTitle TrackInfo
track)
   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 noSpaces :: Text -> Text
noSpaces = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
" " Text
"-" in Text -> Text
noSpaces (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toTitle

-- exampleTrack = TrackInfo "hey jude" "the beatles" "/home"

-- testOnFile fp =
--   do contents <- T.readFile fp
--      return (pipeline contents)

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 -> Lyrics
Lyrics

--
discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text))
discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text))
discriminate onSpan :: Bool
onSpan@Bool
True Tag Text
tag | Tag Text -> Bool
forall str. Tag str -> Bool
isTagText Tag Text
tag = (Bool
onSpan, Tag Text -> Maybe (Tag Text)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tag Text
tag)
discriminate Bool
onSpan Tag Text
tag
  | Text -> ([Attribute Text] -> Bool) -> Tag Text -> Bool
forall str.
Eq str =>
str -> ([Attribute str] -> Bool) -> Tag str -> Bool
tagOpenLit Text
"span" [Attribute Text] -> Bool
goodClasses 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
"span" Tag Text
tag = (Bool
False, Maybe (Tag Text)
forall a. Maybe a
Nothing)
  | Bool
otherwise = (Bool
onSpan, Maybe (Tag Text)
forall a. Maybe a
Nothing)
  where
    goodClasses :: [Attribute Text] -> Bool
goodClasses = (Attribute Text -> Bool) -> [Attribute Text] -> Bool
forall str. ((str, str) -> Bool) -> [(str, str)] -> Bool
anyAttr (\Attribute Text
attr -> Attribute Text -> Set (Attribute Text) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Attribute Text
attr Set (Attribute Text)
spanDiscr)
    spanDiscr :: Set (Attribute Text)
spanDiscr =
      [Attribute Text] -> Set (Attribute Text)
forall a. Ord a => [a] -> Set a
Set.fromList
        [ (Text
"class", Text
"lyrics__content__ok"),
          (Text
"class", Text
"lyrics__content__warning")
        ]