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 qualified as Doc
  18 import Literate.Document.Table
  19 import Literate.Document.Type
  20 import Literate.Prelude
  21 import Text.Blaze
  22 import Text.Blaze.Html5
  23 import Text.Blaze.Html5.Attributes qualified as HA
  24 import Text.Blaze.Renderer.Utf8
  25
  26 instance IsString AttributeValue
  27 instance IsString Html
  28
  29 classes :: [Class] -> Attribute
  30 classes cls =
  31   HA.class_ $
  32     cls
  33       & List.filter (not . Text.null . Doc.unClass)
  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 Block where
 132   toMarkup = \case
 133     BlockDiv
 134       { blockDivAnchor = maybeId
 135       , blockDivClasses = cls
 136       , blockDivBlock = x
 137       } ->
 138         (maybe div (\anchor -> div ! HA.id (anchor & toValue)) maybeId) ! classes cls $
 139           x & toMarkup
 140     BlockFlex x -> x & toMarkup
 141     BlockList x -> x & toMarkup
 142     BlockPara x -> p $ x & toMarkup
 143     BlockTable x -> x & toMarkup
 144     BlockDict x -> x & toMarkup
 145     Blocks xs -> xs & foldMap toMarkup
 146 instance ToMarkup Inline where
 147   toMarkup = \case
 148     InlineText x -> x & toMarkup
 149     InlineCode x -> code $ x & toMarkup
 150     InlineLink{inlineLinkText, inlineLinkTarget} ->
 151       a ! HA.href (inlineLinkTarget & unTarget & toValue) $ inlineLinkText & toMarkup
 152     Inlines xs -> xs & foldMap toMarkup
 153 instance ToMarkup FlexItem where
 154   toMarkup itm =
 155     forM_ (itm & flexItemContent) toMarkup
 156 instance ToMarkup Flex where
 157   toMarkup flx =
 158     div
 159       ! styles
 160         [ "display" := "flex"
 161         , "flex-direction" := flx & flexDirection & toCSS
 162         , "gap" := flx & flexGap & toCSS
 163         ]
 164       $ do
 165         forM_ (flx & flexItems) toMarkup
 166
 167 instance ToMarkup List where
 168   toMarkup List{listItems} =
 169     div
 170       ! classes ["list"]
 171       ! styles
 172         [ "grid-template-columns" :=
 173             [ LengthRelative LengthRelativeMaxContent
 174             , LengthRelative $ 1 & fr
 175             ]
 176               <&> toCSS
 177               & List.unwords
 178         ]
 179       $ do
 180         forM_ (listItems & ol1) \(itemCount, (itemKey, itemValue)) -> do
 181           div ! classes ["list-body", if even itemCount then "even" else "odd"] $ do
 182             div
 183               ! classes ["list-key"]
 184               ! styles ["justify-items" := JustificationRight & toCSS]
 185               $ do
 186                 itemKey & toMarkup
 187             div
 188               ! classes ["list-value"]
 189               ! styles ["justify-items" := JustificationLeft & toCSS]
 190               $ do
 191                 itemValue & toMarkup
 192 instance ToMarkup Table where
 193   toMarkup tbl =
 194     div
 195       ! classes ["table"]
 196       ! styles ["grid-template-columns" := tbl & tableTemplateFinal <&> toCSS & List.unwords]
 197       $ do
 198         forM_ (tbl & tableHeads) \hd -> do
 199           div ! classes ["table-head"] $ do
 200             forM_ (hd & tableHeadColumns) \cel -> do
 201               div ! classes ["table-cell"] $ do
 202                 div do
 203                   cel & tableCellContent & toMarkup
 204         forM_ (tbl & tableRows & ol1) \(rowCount, row) -> do
 205           div ! classes ["table-body", if even rowCount then "even" else "odd"] $ do
 206             forM_ (row & tableRowColumns) \cel -> do
 207               div
 208                 ! classes ["table-cell"]
 209                 ! styles ["justify-items" := cel & tableCellJustify & toCSS]
 210                 $ do
 211                   cel & tableCellContent & toMarkup
 212 instance ToMarkup Dict where
 213   toMarkup dic =
 214     div
 215       ! classes ["dict"]
 216       $ do
 217         forM_ (dic & dictEntries) \(key, val) ->
 218           div ! classes ["dict-entry"] $ do
 219             div ! classes ["dict-key"] $ do
 220               key & toMarkup
 221               "\x202F:"
 222             div ! classes ["dict-value"] $ do
 223               val & toMarkup
 224 instance ToCSS Justification where
 225   toCSS = \case
 226     JustificationLeft -> "left"
 227     JustificationBegin -> "begin"
 228     JustificationCenter -> "center"
 229     JustificationEnd -> "end"
 230     JustificationRight -> "right"
 231 instance ToCSS FlexDirection where
 232   toCSS = \case
 233     FlexDirectionColumn -> "column"
 234     FlexDirectionRow -> "row"