{-# LANGUAGE BangPatterns, CPP, DeriveGeneric, DerivingStrategies,
             DuplicateRecordFields, OverloadedStrings, QuasiQuotes,
             TemplateHaskell, TypeFamilies #-}
module Config.Contributions (
    renderProjectsList
  , renderContributionsTable
#ifdef HADDOCK
  , reqGitHubPinnedRepo
  , renderContributionsTable
  , renderProjectsList
  , GetPinnedRepos (..)
  , GetPinnedReposArgs (..)
  , GetPinnedReposUserPinnedItems (..)
  , GetPinnedReposUserPinnedItemsNodes (..)
  , GetPinnedReposUserPinnedItemsNodesRepository (..)
  , GetPinnedReposUserPinnedItemsNodesLanguages (..)
  , GetPinnedReposUserPinnedItemsNodesLanguagesNodes (..)
#endif
) where

import           Control.Monad             (MonadPlus (..), forM_, (>=>))
import           Control.Monad.Fix         (fix)
import           Control.Monad.Trans.Maybe (MaybeT (..), hoistMaybe)
import qualified Data.ByteString.UTF8      as BU
import           Data.Functor.Identity     (Identity)
import qualified Data.List                 as L
import           Data.Morpheus.Client      (declareLocalTypesInline, fetch, raw)
import           Data.String               (IsString (..))
import           Data.Text.Lazy            as TL
import           Dhall                     (FromDhall, Generic, Natural, auto,
                                            input)
import           Lucid.Base                (HtmlT, renderText)
import           Lucid.Html5
import           Network.HTTP.Req
import           Network.URI               (URI)
import           System.Environment        (lookupEnv)
import           System.FilePath           ((</>))
import           System.Info               (arch, os)

import           Utils.Stack               (getProgNameV)

data Date = Date { Date -> Natural
yyyy :: Natural, Date -> Natural
mm :: Natural, Date -> Natural
dd :: Natural }
    deriving ((forall x. Date -> Rep Date x)
-> (forall x. Rep Date x -> Date) -> Generic Date
forall x. Rep Date x -> Date
forall x. Date -> Rep Date x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Date -> Rep Date x
from :: forall x. Date -> Rep Date x
$cto :: forall x. Rep Date x -> Date
to :: forall x. Rep Date x -> Date
Generic, Int -> Date -> ShowS
[Date] -> ShowS
Date -> String
(Int -> Date -> ShowS)
-> (Date -> String) -> ([Date] -> ShowS) -> Show Date
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Date -> ShowS
showsPrec :: Int -> Date -> ShowS
$cshow :: Date -> String
show :: Date -> String
$cshowList :: [Date] -> ShowS
showList :: [Date] -> ShowS
Show)

instance FromDhall Date

data Project = Project {
    Project -> String
projName :: String
  , Project -> String
lang     :: String
  , Project -> String
summary  :: String
  , Project -> String
projLink :: String
  } deriving ((forall x. Project -> Rep Project x)
-> (forall x. Rep Project x -> Project) -> Generic Project
forall x. Rep Project x -> Project
forall x. Project -> Rep Project x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Project -> Rep Project x
from :: forall x. Project -> Rep Project x
$cto :: forall x. Rep Project x -> Project
to :: forall x. Rep Project x -> Project
Generic, Int -> Project -> ShowS
[Project] -> ShowS
Project -> String
(Int -> Project -> ShowS)
-> (Project -> String) -> ([Project] -> ShowS) -> Show Project
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Project -> ShowS
showsPrec :: Int -> Project -> ShowS
$cshow :: Project -> String
show :: Project -> String
$cshowList :: [Project] -> ShowS
showList :: [Project] -> ShowS
Show)

instance FromDhall Project

data Contribute = Contribute {
    Contribute -> String
text  :: String
  , Contribute -> Date
date  :: Date
  , Contribute -> String
link  :: String
  , Contribute -> String
genre :: String
  } deriving ((forall x. Contribute -> Rep Contribute x)
-> (forall x. Rep Contribute x -> Contribute) -> Generic Contribute
forall x. Rep Contribute x -> Contribute
forall x. Contribute -> Rep Contribute x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Contribute -> Rep Contribute x
from :: forall x. Contribute -> Rep Contribute x
$cto :: forall x. Rep Contribute x -> Contribute
to :: forall x. Rep Contribute x -> Contribute
Generic, Int -> Contribute -> ShowS
[Contribute] -> ShowS
Contribute -> String
(Int -> Contribute -> ShowS)
-> (Contribute -> String)
-> ([Contribute] -> ShowS)
-> Show Contribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Contribute -> ShowS
showsPrec :: Int -> Contribute -> ShowS
$cshow :: Contribute -> String
show :: Contribute -> String
$cshowList :: [Contribute] -> ShowS
showList :: [Contribute] -> ShowS
Show)

instance FromDhall Contribute

loadProjects :: IO [Project]
loadProjects :: IO [Project]
loadProjects = Decoder [Project] -> Text -> IO [Project]
forall a. Decoder a -> Text -> IO a
input Decoder [Project]
forall a. FromDhall a => Decoder a
auto Text
"./contents/config/contributions/Projects.dhall"

loadContributes :: IO [Contribute]
loadContributes :: IO [Contribute]
loadContributes = Decoder [Contribute] -> Text -> IO [Contribute]
forall a. Decoder a -> Text -> IO a
input Decoder [Contribute]
forall a. FromDhall a => Decoder a
auto Text
"./contents/config/contributions/Contributions.dhall"

declareLocalTypesInline "./tools/github/schema.docs.graphql"
    [raw|
        query GetPinnedRepos($user: String!) {
            user(login: $user) {
                pinnedItems(types: REPOSITORY, first: 6) {
                    nodes {
                        ... on Repository {
                            __typename
                            url
                            name
                            description
                            stargazerCount
                            languages(orderBy: {field: SIZE, direction: DESC}, first: 1) {
                                nodes {
                                    name
                                    color
                                }
                            }
                        }
                    }
                }
            }
        }
    |]


-- | Convert pinned repositories to a list of projects.
-- `Nothing` is returned if there is an unexpected failure during conversion.
gitHubResp :: GetPinnedRepos -> MaybeT IO [Project]
gitHubResp :: GetPinnedRepos -> MaybeT IO [Project]
gitHubResp (GetPinnedRepos Maybe GetPinnedReposUser
gpr) = do
    GetPinnedReposUserPinnedItems Maybe [Maybe GetPinnedReposUserPinnedItemsNodes]
ns <- GetPinnedReposUser -> GetPinnedReposUserPinnedItems
pinnedItems (GetPinnedReposUser -> GetPinnedReposUserPinnedItems)
-> MaybeT IO GetPinnedReposUser
-> MaybeT IO GetPinnedReposUserPinnedItems
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GetPinnedReposUser -> MaybeT IO GetPinnedReposUser
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe Maybe GetPinnedReposUser
gpr
    (Maybe GetPinnedReposUserPinnedItemsNodes -> MaybeT IO Project)
-> [Maybe GetPinnedReposUserPinnedItemsNodes]
-> MaybeT IO [Project]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe GetPinnedReposUserPinnedItemsNodes
-> MaybeT IO GetPinnedReposUserPinnedItemsNodes
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe GetPinnedReposUserPinnedItemsNodes
 -> MaybeT IO GetPinnedReposUserPinnedItemsNodes)
-> (GetPinnedReposUserPinnedItemsNodes -> MaybeT IO Project)
-> Maybe GetPinnedReposUserPinnedItemsNodes
-> MaybeT IO Project
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GetPinnedReposUserPinnedItemsNodes -> MaybeT IO Project
forall {m :: * -> *}.
Monad m =>
GetPinnedReposUserPinnedItemsNodes -> MaybeT m Project
unwrap) ([Maybe GetPinnedReposUserPinnedItemsNodes] -> MaybeT IO [Project])
-> MaybeT IO [Maybe GetPinnedReposUserPinnedItemsNodes]
-> MaybeT IO [Project]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Maybe GetPinnedReposUserPinnedItemsNodes]
-> MaybeT IO [Maybe GetPinnedReposUserPinnedItemsNodes]
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe Maybe [Maybe GetPinnedReposUserPinnedItemsNodes]
ns
    where
        unwrap :: GetPinnedReposUserPinnedItemsNodes -> MaybeT m Project
unwrap (GetPinnedReposUserPinnedItemsNodesVariantRepository GetPinnedReposUserPinnedItemsNodesRepository
x) =
            let GetPinnedReposUserPinnedItemsNodesRepository Text
_ URI
projLink' Text
projName' Maybe Text
summary' Int
_ Maybe GetPinnedReposUserPinnedItemsNodesLanguages
langs = GetPinnedReposUserPinnedItemsNodesRepository
x in do
                GetPinnedReposUserPinnedItemsNodesLanguages Maybe [Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes]
langs' <- Maybe GetPinnedReposUserPinnedItemsNodesLanguages
-> MaybeT m GetPinnedReposUserPinnedItemsNodesLanguages
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe Maybe GetPinnedReposUserPinnedItemsNodesLanguages
langs
                String
lang' <- Text -> String
TL.unpack (Text -> String)
-> ((Text, [Text]) -> Text) -> (Text, [Text]) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [Text]) -> Text
forall a b. (a, b) -> a
fst
                    ((Text, [Text]) -> String)
-> MaybeT m (Text, [Text]) -> MaybeT m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Text, [Text]) -> MaybeT m (Text, [Text])
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe (Text, [Text]) -> MaybeT m (Text, [Text]))
-> ([Text] -> Maybe (Text, [Text]))
-> [Text]
-> MaybeT m (Text, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (Text, [Text])
forall a. [a] -> Maybe (a, [a])
L.uncons ([Text] -> MaybeT m (Text, [Text]))
-> MaybeT m [Text] -> MaybeT m (Text, [Text])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes
 -> MaybeT m Text)
-> [Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes]
-> MaybeT m [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes
-> MaybeT m GetPinnedReposUserPinnedItemsNodesLanguagesNodes
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes
 -> MaybeT m GetPinnedReposUserPinnedItemsNodesLanguagesNodes)
-> (GetPinnedReposUserPinnedItemsNodesLanguagesNodes
    -> MaybeT m Text)
-> Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes
-> MaybeT m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GetPinnedReposUserPinnedItemsNodesLanguagesNodes -> MaybeT m Text
forall {f :: * -> *}.
Applicative f =>
GetPinnedReposUserPinnedItemsNodesLanguagesNodes -> f Text
unwrap') ([Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes]
 -> MaybeT m [Text])
-> MaybeT
     m [Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes]
-> MaybeT m [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes]
-> MaybeT
     m [Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes]
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe Maybe [Maybe GetPinnedReposUserPinnedItemsNodesLanguagesNodes]
langs')
                Project -> MaybeT m Project
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project -> MaybeT m Project) -> Project -> MaybeT m Project
forall a b. (a -> b) -> a -> b
$ Project {
                    $sel:projName:Project :: String
projName = Text -> String
TL.unpack Text
projName'
                  , $sel:lang:Project :: String
lang = String
lang'
                  , $sel:summary:Project :: String
summary = String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty Text -> String
TL.unpack (Maybe Text -> String) -> Maybe Text -> String
forall a b. (a -> b) -> a -> b
$ Maybe Text
summary'
                  , $sel:projLink:Project :: String
projLink = URI -> String
forall a. Show a => a -> String
show URI
projLink'
                  }
        unwrap GetPinnedReposUserPinnedItemsNodes
GetPinnedReposUserPinnedItemsNodes = MaybeT m Project
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        unwrap' :: GetPinnedReposUserPinnedItemsNodesLanguagesNodes -> f Text
unwrap' (GetPinnedReposUserPinnedItemsNodesLanguagesNodes Text
l Maybe Text
_) = Text -> f Text
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
l

-- | Use the token to retrieve pinned repositories using the GitHub GraphQL API.
reqGitHubPinnedRepo :: BU.ByteString -> IO [Project]
reqGitHubPinnedRepo :: ByteString -> IO [Project]
reqGitHubPinnedRepo ByteString
token = do
    ByteString -> IO ByteString
jsonRes' <- String -> ByteString -> IO ByteString
jsonRes (String -> ByteString -> IO ByteString)
-> IO String -> IO (ByteString -> IO ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getProgNameV
    (ByteString -> IO ByteString)
-> Args GetPinnedRepos
-> IO (Either (FetchError GetPinnedRepos) GetPinnedRepos)
forall a (m :: * -> *).
(Fetch a, Monad m) =>
(ByteString -> m ByteString)
-> Args a -> m (Either (FetchError a) a)
forall (m :: * -> *).
Monad m =>
(ByteString -> m ByteString)
-> Args GetPinnedRepos
-> m (Either (FetchError GetPinnedRepos) GetPinnedRepos)
fetch ByteString -> IO ByteString
jsonRes' (Text -> GetPinnedReposArgs
GetPinnedReposArgs Text
"falgon")
        IO (Either (FetchError GetPinnedRepos) GetPinnedRepos)
-> (Either (FetchError GetPinnedRepos) GetPinnedRepos
    -> IO [Project])
-> IO [Project]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FetchError GetPinnedRepos -> IO [Project])
-> (GetPinnedRepos -> IO [Project])
-> Either (FetchError GetPinnedRepos) GetPinnedRepos
-> IO [Project]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO [Project] -> FetchError GetPinnedRepos -> IO [Project]
forall a b. a -> b -> a
const IO [Project]
loadProjects) (MaybeT IO [Project] -> IO (Maybe [Project])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [Project] -> IO (Maybe [Project]))
-> (GetPinnedRepos -> MaybeT IO [Project])
-> GetPinnedRepos
-> IO (Maybe [Project])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetPinnedRepos -> MaybeT IO [Project]
gitHubResp (GetPinnedRepos -> IO (Maybe [Project]))
-> (Maybe [Project] -> IO [Project])
-> GetPinnedRepos
-> IO [Project]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO [Project]
-> ([Project] -> IO [Project]) -> Maybe [Project] -> IO [Project]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [Project]
loadProjects [Project] -> IO [Project]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    where
        jsonRes :: String -> ByteString -> IO ByteString
jsonRes String
progName ByteString
b = HttpConfig -> Req ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req ByteString -> IO ByteString)
-> Req ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ LbsResponse -> ByteString
LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody
            (LbsResponse -> ByteString) -> Req LbsResponse -> Req ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> POST
-> Url 'Https
-> ReqBodyLbs
-> Proxy LbsResponse
-> Option 'Https
-> Req LbsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST (Text -> Url 'Https
https Text
"api.github.com" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"graphql") (ByteString -> ReqBodyLbs
ReqBodyLbs ByteString
b) Proxy LbsResponse
lbsResponse (String -> Option 'Https
headers String
progName)
        headers :: String -> Option 'Https
headers String
progName = [Option 'Https] -> Option 'Https
forall a. Monoid a => [a] -> a
mconcat [
            ByteString -> ByteString -> Option 'Https
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"Content-Type" ByteString
"application/json"
          , ByteString -> ByteString -> Option 'Https
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"User-Agent" (ByteString -> Option 'Https) -> ByteString -> Option 'Https
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
progName, String
" (", String
os, String
"; ", String
arch, String
")" ]
          , ByteString -> Option 'Https
oAuth2Bearer ByteString
token
          ]

-- | Returns the html of your favorite projects list as a `String`.
renderProjectsList :: IO String
renderProjectsList :: IO String
renderProjectsList = do
    [Project]
ps <- IO [Project]
-> (String -> IO [Project]) -> Maybe String -> IO [Project]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [Project]
loadProjects (ByteString -> IO [Project]
reqGitHubPinnedRepo (ByteString -> IO [Project])
-> (String -> ByteString) -> String -> IO [Project]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BU.fromString) (Maybe String -> IO [Project]) -> IO (Maybe String) -> IO [Project]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
lookupEnv String
"GITHUB_TOKEN"
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$
        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
dl_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Project] -> (Project -> HtmlT Identity ()) -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Project]
ps ((Project -> HtmlT Identity ()) -> HtmlT Identity ())
-> (Project -> HtmlT Identity ()) -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ \Project
p -> do
            [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
dt_ [Text -> Attribute
class_ Text
"title is-4"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Project -> String
projLink Project
p] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT Identity ()
forall a. IsString a => String -> a
fromString (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Project -> String
projName Project
p
                [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"ml-2 tag is-success is-light"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT Identity ()
forall a. IsString a => String -> a
fromString (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Project -> String
lang Project
p
            [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
dd_ [Text -> Attribute
class_ Text
"mb-6"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT Identity ()
forall a. IsString a => String -> a
fromString (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Project -> String
summary Project
p

-- | Returns the contribution list in html tabular format as a `String`.
renderContributionsTable :: IO String
renderContributionsTable :: IO String
renderContributionsTable = do
    [Contribute]
cs <- IO [Contribute]
loadContributes
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
id_ Text
"contributions_table"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$
        [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
table_ [Text -> Attribute
class_ Text
"table is-fullwidth is-hoverable"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
            HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
thead_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tr_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
th_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
abbr_ [Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ Text
"Index"] HtmlT Identity ()
"#"
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
th_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
abbr_ [Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ Text
"Contents"] HtmlT Identity ()
"Contents"
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
th_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
abbr_ [Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ Text
"Genre"] HtmlT Identity ()
"Genre"
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
th_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
abbr_ [Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ Text
"Date"] HtmlT Identity ()
"Date"
            HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tbody_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ ((([Contribute], Int) -> HtmlT Identity ())
-> ([Contribute], Int) -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ ([Contribute]
cs, Int
1 :: Int)) ((([Contribute], Int) -> HtmlT Identity ()) -> HtmlT Identity ())
-> (([Contribute], Int) -> HtmlT Identity ()) -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ ((([Contribute], Int) -> HtmlT Identity ())
 -> ([Contribute], Int) -> HtmlT Identity ())
-> ([Contribute], Int) -> HtmlT Identity ()
forall a. (a -> a) -> a
fix (((([Contribute], Int) -> HtmlT Identity ())
  -> ([Contribute], Int) -> HtmlT Identity ())
 -> ([Contribute], Int) -> HtmlT Identity ())
-> ((([Contribute], Int) -> HtmlT Identity ())
    -> ([Contribute], Int) -> HtmlT Identity ())
-> ([Contribute], Int)
-> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ \([Contribute], Int) -> HtmlT Identity ()
f ([Contribute]
cs', !Int
i) -> case [Contribute]
cs' of
                [] -> () -> HtmlT Identity ()
forall a. a -> HtmlT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. Monoid a => a
mempty :: HtmlT Identity ()
                (Contribute
c:[Contribute]
cs'') -> do
                    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tr_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
td_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT Identity ()
forall a. IsString a => String -> a
fromString (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
                        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
td_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Contribute -> String
link Contribute
c)] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT Identity ()
forall a. IsString a => String -> a
fromString (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Contribute -> String
text Contribute
c
                        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
td_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"tag is-success is-light"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT Identity ()
forall a. IsString a => String -> a
fromString (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Contribute -> String
genre Contribute
c
                        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
td_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ let c' :: Date
c' = Contribute -> Date
date Contribute
c in
                            String -> HtmlT Identity ()
forall a. IsString a => String -> a
fromString (Natural -> String
forall a. Show a => a -> String
show (Date -> Natural
yyyy Date
c') String -> ShowS
</> Natural -> String
forall a. Show a => a -> String
show (Date -> Natural
mm Date
c') String -> ShowS
</> Natural -> String
forall a. Show a => a -> String
show (Date -> Natural
dd Date
c'))
                    ([Contribute], Int) -> HtmlT Identity ()
f ([Contribute]
cs'', Int -> Int
forall a. Enum a => a -> a
succ Int
i)