src/Literate/Document/HTML.hs

   1 {-# LANGUAGE OverloadedLists #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -Wno-orphans #-}
   4
   5 module Literate.Document.HTML (
   6   module Literate.Document.HTML,
   7   module Text.Blaze.Html5,
   8   module Text.Blaze.Renderer.Utf8,
   9 )
  10 where
  11
  12 import Data.Char qualified as Char
  13 import Data.List qualified as List
  14 import Data.Map.Strict qualified as Map
  15 import Data.Text qualified as Text
  16 import Data.Text.Short qualified as ShortText
  17 import Literate.Document.Table
  18 import Literate.Document.Type
  19 import Literate.Prelude
  20 import Text.Blaze
  21 import Text.Blaze.Html5
  22 import Text.Blaze.Html5.Attributes qualified as HA
  23 import Text.Blaze.Renderer.Utf8
  24 import Prelude qualified
  25
  26 instance IsString AttributeValue
  27 instance IsString Html
  28
  29 classes :: [String] -> Attribute
  30 classes cls =
  31   HA.class_ $
  32     cls
  33       & List.filter (not . null)
  34       <&> toValue
  35       & List.intersperse " "
  36       & mconcat
  37
  38 className :: Show a => a -> String
  39 className x =
  40   x & show & List.map \c ->
  41     if Char.isAlphaNum c
  42       then c
  43       else '-'
  44
  45 type CSSBlock = Map String String
  46
  47 styles :: CSSBlock -> Attribute
  48 styles kvs =
  49   HA.style $
  50     [ toValue k <> ":" <> toValue v <> ";"
  51     | (k, v) <- kvs & Map.toList
  52     , not (null v)
  53     ]
  54       & mconcat
  55
  56 type CSS = Map [String] CSSBlock
  57 styleCSS :: CSS -> Markup
  58 styleCSS m =
  59   style
  60     ! HA.type_ "text/css"
  61     $ [ mconcat [n <> " {" | n <- ns]
  62         <> "\n"
  63         <> List.unlines
  64           [ k <> ":" <> v <> ";"
  65           | (k, v) <- kvs & Map.toList
  66           , not (null v)
  67           ]
  68         <> mconcat [" }" | _n <- ns]
  69         <> "\n"
  70       | (ns, kvs) <- m & Map.toList
  71       , kvs & null & not
  72       ]
  73       & List.unlines
  74       & toMarkup
  75
  76 class ToCSS a where
  77   toCSS :: a -> String
  78
  79 instance ToMarkup ShortText where
  80   toMarkup = ShortText.toText >>> toMarkup
  81   preEscapedToMarkup = ShortText.toText >>> preEscapedToMarkup
  82
  83 instance ToCSS Text where
  84   toCSS = Text.unpack
  85
  86 instance ToCSS Length where
  87   toCSS = \case
  88     LengthAbsolute x -> x & toCSS
  89     LengthRelative x -> x & toCSS
  90 instance ToCSS LengthAbsolute where
  91   toCSS = \case
  92     LengthAbsoluteMillimeters x -> show x <> "mm"
  93 instance ToCSS LengthRelative where
  94   toCSS = \case
  95     LengthRelativeFractionalRatio x -> show x <> "fr"
  96     LengthRelativeMaxContent -> "max-content"
  97     LengthRelativeMinContent -> "min-content"
  98
  99 cssPageWidth = \case
 100   PageOrientationLandscape -> 29.7 & cm
 101   PageOrientationPortrait -> 21.0 & cm
 102 cssPageHeight = \case
 103   PageOrientationLandscape -> 21.0 & cm
 104   PageOrientationPortrait -> 29.7 & cm
 105 cssPageSize = \case
 106   PageSizeA5 -> "A5"
 107   PageSizeA4 -> "A4"
 108   PageSizeA4Plus -> "A4plus"
 109   PageSizeA3 -> "A3"
 110 cssPageOrientation = \case
 111   PageOrientationPortrait -> "portrait"
 112   PageOrientationLandscape -> "landscape"
 113
 114 cssPrintPage :: PageOrientation -> PageSize -> CSS
 115 cssPrintPage pageOrient pageSize =
 116   [
 117     [ ["@page"] :=
 118         [ "size" :=
 119             List.unwords
 120               [ cssPageSize pageSize
 121               , cssPageOrientation pageOrient
 122               ]
 123         ]
 124     ]
 125   ]
 126     & mconcat
 127
 128 cssBlockObjectFitCover :: CSSBlock
 129 cssBlockObjectFitCover = ["object-fit" := "cover"]
 130
 131 instance ToMarkup Blocks where
 132   toMarkup = foldMap toMarkup . unBlocks
 133 instance ToMarkup Block where
 134   toMarkup = \case
 135     BlockDiv x -> div $ x & toMarkup
 136     BlockFlex x -> x & toMarkup
 137     BlockPara (Inlines x) -> p $ x & foldMap toMarkup
 138     BlockTable x -> x & toMarkup
 139 instance ToMarkup Inline where
 140   toMarkup = \case
 141     InlineText x -> x & toMarkup
 142 instance ToMarkup FlexItem where
 143   toMarkup itm =
 144     forM_ (itm & flexItemContent) toMarkup
 145 instance ToMarkup Flex where
 146   toMarkup flx =
 147     div
 148       ! styles
 149         [ "display" := "flex"
 150         , "flex-direction" := flx & flexDirection & toCSS
 151         , "gap" := flx & flexGap & toCSS
 152         ]
 153       $ do
 154         forM_ (flx & flexItems) toMarkup
 155
 156 instance ToMarkup Table where
 157   toMarkup tbl =
 158     div
 159       ! classes ["table"]
 160       ! styles ["grid-template-columns" := tbl & tableTemplateFinal <&> toCSS & List.unwords]
 161       $ do
 162         forM_ (tbl & tableHeads) \hd -> do
 163           div ! classes ["table-head"] $ do
 164             forM_ (hd & tableHeadColumns) \cel -> do
 165               div ! classes ["table-cell"] $ do
 166                 div do
 167                   cel & tableCellContent & toMarkup
 168         forM_ (tbl & tableRows & ol1) \(rowCount, row) -> do
 169           div ! classes ["table-body", if even rowCount then "even" else "odd"] $ do
 170             forM_ (row & tableRowColumns) \cel -> do
 171               div
 172                 ! classes ["table-cell"]
 173                 ! styles ["justify-items" := cel & tableCellJustify & toCSS]
 174                 $ do
 175                   cel & tableCellContent & toMarkup
 176 instance ToMarkup Dict where
 177   toMarkup dic =
 178     div
 179       ! classes ["dict"]
 180       $ do
 181         forM_ (dic & dictEntries) \(key, val) ->
 182           div ! classes ["dict-entry"] $ do
 183             div ! classes ["dict-key"] $ do
 184               key & toMarkup
 185             div ! classes ["dict-value"] $ do
 186               val & toMarkup
 187 instance ToCSS Justification where
 188   toCSS = \case
 189     JustificationLeft -> "left"
 190     JustificationBegin -> "begin"
 191     JustificationCenter -> "center"
 192     JustificationEnd -> "end"
 193     JustificationRight -> "right"
 194 instance ToCSS FlexDirection where
 195   toCSS = \case
 196     FlexDirectionColumn -> "column"
 197     FlexDirectionRow -> "row"