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 Text where
  75   toCSS = Text.unpack
  76 instance ToCSS Length where
  77   toCSS = \case
  78     LengthFractionalRatio x -> show x <> "fr"
  79     LengthMillimeters x -> show x <> "mm"
  80 cm :: Double -> Length
  81 cm = LengthMillimeters . (* 10)
  82 mm :: Double -> Length
  83 mm = LengthMillimeters
  84 fr :: Natural -> Length
  85 fr = LengthFractionalRatio
  86
  87 cssPageWidth = \case
  88   PageOrientationLandscape -> 29.7 & cm
  89   PageOrientationPortrait -> 21.0 & cm
  90 cssPageHeight = \case
  91   PageOrientationLandscape -> 21.0 & cm
  92   PageOrientationPortrait -> 29.7 & cm
  93 cssPageSize = \case
  94   PageSizeA5 -> "A5"
  95   PageSizeA4 -> "A4"
  96   PageSizeA4Plus -> "A4plus"
  97   PageSizeA3 -> "A3"
  98 cssPageOrientation = \case
  99   PageOrientationPortrait -> "portrait"
 100   PageOrientationLandscape -> "landscape"
 101
 102 cssPrintPage :: PageOrientation -> PageSize -> CSS
 103 cssPrintPage pageOrient pageSize =
 104   [
 105     [ ["@page"] :=
 106         [ "size" :=
 107             List.unwords
 108               [ cssPageSize pageSize
 109               , cssPageOrientation pageOrient
 110               ]
 111         ]
 112     ]
 113   ]
 114     & mconcat
 115
 116 cssBlockObjectFitCover :: CSSBlock
 117 cssBlockObjectFitCover = ["object-fit" := "cover"]