{-# LANGUAGE TemplateHaskell #-}

module Futhark.Util.Html
  ( relativise,
    headHtmlWithCss,
    headHtml,
    cssFile,
  )
where

import Data.FileEmbed (embedStringFile)
import Data.String (fromString)
import Data.Text qualified as T
import System.FilePath (makeRelative, splitPath)
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A

cssFile :: T.Text
cssFile :: Text
cssFile = $(embedStringFile "rts/style.css")

relativise :: FilePath -> FilePath -> FilePath
relativise :: [Char] -> [Char] -> [Char]
relativise [Char]
dest [Char]
src =
  [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [Char] -> [[Char]]
forall a. Int -> a -> [a]
replicate ([[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> [[Char]]
splitPath [Char]
src) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Char]
"../") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char] -> [Char]
makeRelative [Char]
"/" [Char]
dest

headHtmlWithCss :: String -> String -> H.Html
headHtmlWithCss :: [Char] -> [Char] -> Html
headHtmlWithCss [Char]
cssPath [Char]
titleText =
  Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    Html
H.meta
      Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.charset AttributeValue
"utf-8"
      Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html -> Html
H.title ([Char] -> Html
forall a. IsString a => [Char] -> a
fromString [Char]
titleText)
      Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
H.link
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href ([Char] -> AttributeValue
forall a. IsString a => [Char] -> a
fromString [Char]
cssPath)
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css"

headHtml :: FilePath -> String -> H.Html
headHtml :: [Char] -> [Char] -> Html
headHtml [Char]
current = [Char] -> [Char] -> Html
headHtmlWithCss ([Char] -> [Char] -> [Char]
relativise [Char]
"style.css" [Char]
current)