{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Render (renderFrontpage, renderMonthview) where import Control.Monad (forM_) import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Time (Day, MonthOfYear, Year, addDays, addGregorianMonthsClip, dayOfWeek, defaultTimeLocale, formatTime, fromGregorian, toGregorian) import Ical import Lucid import Text.Printf (printf) renderHead :: Html () renderHead = do doctype_ head_ $ do meta_ [charset_ "UTF-8"] meta_ [ name_ "viewport", content_ "width=device-width, initial-scale=1.0" ] meta_ [ name_ "description", content_ "Chipburners home page" ] title_ "Chipburners" link_ [rel_ "stylesheet", href_ "/style.css"] renderHeader :: Int -> Html () renderHeader active = header_ [class_ "site-header"] $ do nav_ [] $ do ul_ [class_ "nav-list"] $ do li_ $ a_ [href_ "/", getActive 0] "Chip" li_ $ a_ [href_ "/monthView", getActive 1] "Eventos" li_ $ a_ [href_ "/wiki", getActive 2] "Wiki" li_ $ a_ [href_ "/contact", getActive 3] "Contacto" where getActive cur = if cur == active then class_ "active" else class_ "inactive" renderImage :: T.Text -> T.Text -> T.Text -> Html () renderImage url caption alt = figure_ $ do img_ [ src_ url, alt_ alt, loading_ "lazy" ] figcaption_ $ toHtml caption renderSideEvent :: Event -> Html () renderSideEvent e = li_ $ do span_ [class_ "event-time"] $ toHtml (formatTime defaultTimeLocale "%H:%M" (dtStart e)) span_ [class_ "event-title"] $ do let uid = euid e a_ [href_ ("/monthView#" <> uid), class_ "event-link"] $ toHtml (summary e) renderDayGroup :: (Day, [Event]) -> Html () renderDayGroup (day, events) = li_ [class_ "event-group"] $ do time_ [ datetime_ $ T.pack (formatTime defaultTimeLocale "%Y-%m-%d" day), class_ "date-header" ] $ toHtml $ T.pack (formatTime defaultTimeLocale "%A %d.%m.%y" day) ul_ [class_ "daily-events"] $ mapM_ renderSideEvent events renderEventList :: [Event] -> Html () -- mapM_ only cares about the monad I think? So it throws away the () part -- mapM applies the monad to everz element of the list and returns monad with a list? renderEventList events = mapM_ renderDayGroup (groupEvents events) renderFrontpage :: [Event] -> Html () renderFrontpage events = do doctype_ html_ [lang_ "es"] $ do renderHead body_ $ do renderHeader 0 div_ [class_ "wrapper"] $ do div_ [class_ "layout"] $ do main_ [id_ "main-content", class_ "content"] $ do section_ [class_ "intro"] $ do h1_ "Chipburners_" p_ [class_ "lead"] $ "Frase motivadora aqui" p_ $ do "Buenos dias, " br_ [] "Somos un grupo d personas y entidades interesados en infromatica y \ \las technologias relacionadas. " br_ [] "Este hackerspace ha sido creado como manera d juntar gente con intereses \ \similares y compartir conocimientos. " br_ [] "Contactanos en " a_ [href_ "/contact"] "signal" "!" section_ [class_ "image-gallery"] $ do renderImage "example.com" "Imagen sobre algo" "Imagen interesante" aside_ [class_ "sidebar"] $ do section_ [class_ "events-panel"] $ do h2_ "Eventos" renderEventList events chunksOf :: Int -> [a] -> [[a]] chunksOf _ [] = [] chunksOf n xs = let (ys, zs) = splitAt n xs in ys : chunksOf n zs padZero :: Int -> String padZero n = if n < 10 then "0" ++ show n else show n renderCalendarEvent :: Event -> Html () renderCalendarEvent e = do let uid = euid e li_ [class_ "event-item"] $ do -- (toHtml $ summary e) a_ [href_ ("#" <> uid), class_ "event-link"] $ toHtml (summary e) div_ [class_ "event-popup", id_ uid] $ do h1_ [] $ do (toHtml $ summary e) a_ [ href_ ("#None"), class_ "close-btn" ] "×" p_ [class_ "lead"] $ toHtml $ T.pack $ printf "%s -> %s - %s" (formatTime defaultTimeLocale "%A %d.%m.%y" $ dtStart e) (formatTime defaultTimeLocale "%H:%M" $ dtStart e) (formatTime defaultTimeLocale "%H:%M" $ dtEnd e) p_ [] $ toHtml $ description e renderMonthview :: (Year, MonthOfYear) -> Day -> [(Day, [Event])] -> Html () renderMonthview (year, month) today groupedEvents = do let firstOfMonth = fromGregorian year month 1 wd = dayOfWeek firstOfMonth daysToSubtract = fromEnum wd - 1 startOfGrid = addDays (fromIntegral (-daysToSubtract)) firstOfMonth gridDays = [addDays i startOfGrid | i <- [0 .. 41]] weeks = chunksOf 7 gridDays prevMonthDay = addGregorianMonthsClip (-1) firstOfMonth nextMonthDay = addGregorianMonthsClip 1 firstOfMonth (py, pm, _) = toGregorian prevMonthDay (cy, cm, _) = toGregorian today (ny, nm, _) = toGregorian nextMonthDay mkLink y m label = a_ [ href_ $ T.pack $ printf "/monthView/%s/%s" (show y) (padZero m), class_ "nav-link" ] label renderHead renderHeader 1 div_ [class_ "calendar-wrapper"] $ do header_ [class_ "calendar-header"] $ do h1_ [class_ "view-title"] "Vista mensual" nav_ [class_ "calendar-nav"] $ do mkLink py pm "« Mes pasado" mkLink cy cm "Este mes" mkLink ny nm "Mes siguiente »" h2_ [class_ "month-name"] $ toHtml $ formatTime defaultTimeLocale "%B %Y" $ fromGregorian year month 1 table_ [class_ "calendar-table"] $ do thead_ $ do tr_ $ do th_ "Lunes" th_ "Martes" th_ "Miercoles" th_ "Jueves" th_ "Viernes" th_ "Sabado" th_ "Domingo" tbody_ $ do forM_ weeks $ \week -> do tr_ $ do forM_ week $ \d -> do let (_, dM, dD) = toGregorian d isCurrentMonth = dM == month isToday = d == today baseClasses = [] monthClass = if isCurrentMonth then [] else ["other-month"] todayClass = if isToday then ["current-day"] else [] finalClass = T.intercalate " " (baseClasses ++ monthClass ++ todayClass) -- TODO: lookup very slow :( dayEvents = fromMaybe [] (lookup d groupedEvents) -- cool td_ ([class_ finalClass | not (T.null finalClass)]) $ do span_ [class_ "day-number"] (toHtml $ show dD) if null dayEvents then return () else ul_ [class_ "event-list"] $ do forM_ dayEvents $ \e -> renderCalendarEvent e