src/Worksheets/Utils/HTML.hs

   1 {-# LANGUAGE OverloadedLists #-}
   2 {-# OPTIONS_GHC -Wno-orphans #-}
   3
   4 module Worksheets.Utils.HTML (
   5   module Worksheets.Utils.HTML,
   6   module Text.Blaze.Html5,
   7   module Text.Blaze.Renderer.Utf8,
   8 ) where
   9
  10 import Data.Char qualified as Char
  11 import Data.List qualified as List
  12 import Data.Map.Strict qualified as Map
  13 import Data.Text qualified as Text
  14 import Data.Text.Short qualified as ShortText
  15 import Text.Blaze
  16 import Text.Blaze.Html5
  17 import Text.Blaze.Html5.Attributes qualified as HA
  18 import Text.Blaze.Renderer.Utf8
  19 import Worksheets.Utils.Paper
  20 import Worksheets.Utils.Prelude
  21
  22 classes :: [String] -> Attribute
  23 classes cls = HA.class_ $ cls & List.filter (not . null) <&> toValue & List.intersperse " " & mconcat
  24
  25 className :: Show a => a -> String
  26 className x =
  27   x & show & List.map \c ->
  28     if Char.isAlphaNum c
  29       then c
  30       else '-'
  31
  32 type CSSBlock = Map String String
  33
  34 styles :: CSSBlock -> Attribute
  35 styles kvs =
  36   HA.style $
  37     [ toValue k <> ":" <> toValue v <> ";"
  38     | (k, v) <- kvs & Map.toList
  39     , not (null v)
  40     ]
  41       & mconcat
  42
  43 type CSS = Map [String] CSSBlock
  44 styleCSS :: CSS -> Markup
  45 styleCSS m =
  46   style
  47     ! HA.type_ "text/css"
  48     $ [ mconcat [n <> " {" | n <- ns]
  49           <> "\n"
  50           <> List.unlines
  51             [ k <> ":" <> v <> ";"
  52             | (k, v) <- kvs & Map.toList
  53             , not (null v)
  54             ]
  55           <> mconcat [" }" | _n <- ns]
  56           <> "\n"
  57       | (ns, kvs) <- m & Map.toList
  58       , kvs & null & not
  59       ]
  60       & List.unlines
  61       & toHtml
  62
  63 class ToCSS a where
  64   toCSS :: a -> String
  65
  66 instance ToMarkup ShortText where
  67   toMarkup = ShortText.toText >>> toMarkup
  68   preEscapedToMarkup = ShortText.toText >>> preEscapedToMarkup
  69
  70 data Length
  71   = LengthFractionalRatio Natural
  72   | LengthMillimeters Double
  73   deriving (Eq, Show)
  74 instance ToCSS String where
  75   toCSS = id
  76 instance ToCSS Text where
  77   toCSS = Text.unpack
  78 instance ToCSS Double where
  79   toCSS = show >>> toCSS
  80 instance ToCSS a => ToCSS (Maybe a) where
  81   toCSS = maybe "" toCSS
  82 instance ToCSS Length where
  83   toCSS = \case
  84     LengthFractionalRatio x -> show x <> "fr"
  85     LengthMillimeters x -> show x <> "mm"
  86 cm :: Double -> Length
  87 cm = LengthMillimeters . (* 10)
  88 mm :: Double -> Length
  89 mm = LengthMillimeters
  90 fr :: Natural -> Length
  91 fr = LengthFractionalRatio
  92
  93 cssPageWidth = \case
  94   PageOrientationLandscape -> 29.7 & cm
  95   PageOrientationPortrait -> 21.0 & cm
  96 cssPageHeight = \case
  97   PageOrientationLandscape -> 21.0 & cm
  98   PageOrientationPortrait -> 29.7 & cm
  99 cssPageSize = \case
 100   PageSizeA5 -> "A5"
 101   PageSizeA4 -> "A4"
 102   PageSizeA4Plus -> "A4plus"
 103   PageSizeA3 -> "A3"
 104 cssPageOrientation = \case
 105   PageOrientationPortrait -> "portrait"
 106   PageOrientationLandscape -> "landscape"
 107
 108 cssPrintPage :: PageOrientation -> PageSize -> CSS
 109 cssPrintPage pageOrient pageSize =
 110   [
 111     [ ["@page"] :=
 112         [ "size" :=
 113             List.unwords
 114               [ cssPageSize pageSize
 115               , cssPageOrientation pageOrient
 116               ]
 117         ]
 118     ]
 119   ]
 120     & mconcat
 121
 122 cssBlockObjectFitCover :: CSSBlock
 123 cssBlockObjectFitCover = ["object-fit" := "cover"]