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