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.String qualified as String
  16 import Data.Text qualified as Text
  17 import Data.Text.Short qualified as ShortText
  18 import Data.Time.Format.ISO8601 qualified as Time
  19 import Data.Time.LocalTime qualified as Time
  20 import Literate.Document qualified as Doc
  21 import Literate.Document.Table
  22 import Literate.Document.Type hiding (classes)
  23 import Literate.Prelude
  24 import System.FilePath.Posix ((</>))
  25 import Text.Blaze
  26 import Text.Blaze.Html5
  27 import Text.Blaze.Html5.Attributes qualified as HA
  28 import Text.Blaze.Internal (MarkupM (Parent))
  29 import Text.Blaze.Renderer.Utf8
  30 import Text.Printf qualified as Printf
  31
  32 instance IsString AttributeValue
  33 instance IsString Html
  34
  35 classes :: [Class] -> (Bool, Attribute)
  36 classes cls =
  37   ( not $ null clsFiltered
  38   , HA.class_ $ clsFiltered <&> toValue & List.intersperse " " & mconcat
  39   )
  40   where
  41     clsFiltered = cls & List.filter (not . Text.null . Doc.unClass)
  42
  43 className :: Show a => a -> String
  44 className x =
  45   x & show & List.map \c ->
  46     if Char.isAlphaNum c
  47       then c
  48       else '-'
  49
  50 type CSSBlock = Map String String
  51
  52 styles :: CSSBlock -> (Bool, Attribute)
  53 styles kvs =
  54   ( styFiltered & null & not
  55   , HA.style $
  56       mconcat
  57         [ toValue k <> ":" <> toValue v <> ";"
  58         | (k, v) <- styFiltered
  59         ]
  60   )
  61   where
  62     styFiltered = kvs & Map.toList & List.filter \(_k, v) -> v & null & not
  63
  64 type CSS = Map [String] CSSBlock
  65 styleCSS :: CSS -> Markup
  66 styleCSS m =
  67   style
  68     ! HA.type_ "text/css"
  69     $ [ mconcat [n <> " {" | n <- ns]
  70           <> "\n"
  71           <> List.unlines
  72             [ k <> ":" <> v <> ";"
  73             | (k, v) <- kvs & Map.toList
  74             , not (null v)
  75             ]
  76           <> mconcat [" }" | _n <- ns]
  77           <> "\n"
  78       | (ns, kvs) <- m & Map.toList
  79       , kvs & null & not
  80       ]
  81       & List.unlines
  82       & toMarkup
  83
  84 class ToCSS a where
  85   toCSS :: a -> String
  86
  87 instance ToMarkup ShortText where
  88   toMarkup = ShortText.toText >>> toMarkup
  89   preEscapedToMarkup = ShortText.toText >>> preEscapedToMarkup
  90 instance ToCSS a => ToCSS (Maybe a) where
  91   toCSS = maybe "" toCSS
  92 instance ToCSS Text where
  93   toCSS = Text.unpack
  94 instance ToCSS Length where
  95   toCSS = \case
  96     LengthAbsolute x -> x & toCSS
  97     LengthRelative x -> x & toCSS
  98 instance ToCSS LengthAbsolute where
  99   toCSS = \case
 100     LengthAbsoluteMillimeters x -> show x <> "mm"
 101 instance ToCSS LengthRelative where
 102   toCSS = \case
 103     LengthRelativeFractionalRatio x -> show x <> "fr"
 104     LengthRelativeMaxContent -> "max-content"
 105     LengthRelativeMinContent -> "min-content"
 106 instance ToCSS PageSize where
 107   toCSS = \case
 108     PageSizeA5 -> "A5"
 109     PageSizeA4 -> "A4"
 110     PageSizeA4Plus -> "A4plus"
 111     PageSizeA3 -> "A3"
 112 instance ToCSS PageOrientation where
 113   toCSS = \case
 114     PageOrientationPortrait -> "portrait"
 115     PageOrientationLandscape -> "landscape"
 116 instance ToCSS Justify where
 117   toCSS = \case
 118     JustifyCenter -> "center"
 119     JustifyEnd -> "end"
 120     JustifySpaceAround -> "space-around"
 121     JustifySpaceBetween -> "space-between"
 122     JustifySpaceEvenly -> "space-evenly"
 123     JustifyStart -> "start"
 124 instance ToCSS Align where
 125   toCSS = \case
 126     AlignBaseline -> "baseline"
 127     AlignBaselineFirst -> "first-baseline"
 128     AlignBaselineLast -> "last-baseline"
 129     AlignCenter -> "center"
 130     AlignEnd -> "end"
 131     AlignSpaceAround -> "space-around"
 132     AlignSpaceBetween -> "space-between"
 133     AlignSpaceEvenly -> "space-evenly"
 134     AlignStart -> "start"
 135     AlignStretch -> "stretch"
 136 instance ToCSS FlexDirection where
 137   toCSS = \case
 138     FlexDirectionColumn -> "column"
 139     FlexDirectionRow -> "row"
 140
 141 cssPageWidth = \case
 142   PageOrientationLandscape -> 29.7 & cm
 143   PageOrientationPortrait -> 21.0 & cm
 144
 145 cssPageHeight = \case
 146   PageOrientationLandscape -> 21.0 & cm
 147   PageOrientationPortrait -> 29.7 & cm
 148
 149 cssPrintPage :: PageOrientation -> PageSize -> CSS
 150 cssPrintPage pageOrient pageSize =
 151   [
 152     [ ["@page"] :=
 153         [ "size" :=
 154             List.unwords
 155               [ pageSize & toCSS
 156               , pageOrient & toCSS
 157               ]
 158         ]
 159     ]
 160   ]
 161     & mconcat
 162
 163 cssBlockObjectFitCover :: CSSBlock
 164 cssBlockObjectFitCover = ["object-fit" := "cover"]
 165
 166 instance ToMarkup (FilePath, Document) where
 167   toMarkup (dataPath, doc) =
 168     docTypeHtml do
 169       head do
 170         title do
 171           doc & documentTitle & toMarkup
 172         forM_ (doc & documentAttachments & Map.findWithDefault [] "css") \cssFile -> do
 173           link
 174             ! HA.rel "stylesheet"
 175             ! HA.type_ "text/css"
 176             ! HA.href (dataPath </> (cssFile & Text.unpack) & toValue)
 177       body do
 178         forM_ (doc & documentPages) \pag -> do
 179           pag & toMarkup
 180 instance ToMarkup Page where
 181   toMarkup pag =
 182     div
 183       !? classes
 184         [ "page"
 185         , pag & pageSize & toCSS & Text.pack & Class
 186         , pag & pageOrientation & toCSS & Text.pack & Class
 187         ]
 188       !? styles
 189         [ "size" :=
 190             List.unwords
 191               [ pag & pageSize & toCSS
 192               , pag & pageOrientation & toCSS
 193               ]
 194         , "display" := "flex"
 195         ]
 196       $ (!? styles ["width" := "100%"])
 197       $ toHtml
 198       $ Doc.BlockFlex
 199         Doc.flex
 200           { Doc.flexDirection = Doc.FlexDirectionColumn
 201           , Doc.flexGap = 0.5 & Doc.cm
 202           , Doc.flexJustifyContent = Just JustifySpaceBetween
 203           , Doc.flexAlignContent = Just AlignStretch
 204           , Doc.flexItems =
 205               [ [Doc.flexItem{Doc.flexItemContent = pag & Doc.pageContent & Doc.toBlock}]
 206               ,
 207                 [ Doc.flexItem
 208                     { Doc.flexItemContent =
 209                         Doc.flex
 210                           { Doc.flexDirection = Doc.FlexDirectionRow
 211                           , Doc.flexGap = 0.5 & Doc.cm
 212                           , Doc.flexJustifyContent = Just JustifySpaceBetween
 213                           , Doc.flexItems =
 214                               [ Doc.flexItem
 215                                   { Doc.flexItemContent =
 216                                       [ ( [ pag & Doc.pageNumber & maybe [] \n -> [n & Printf.printf "%d" & Text.pack]
 217                                           , pag & Doc.pageNumberTotal & maybe [] \n -> [n & Printf.printf "%d" & Text.pack]
 218                                           ]
 219                                             & mconcat
 220                                             & mconcat
 221                                             & Text.intersperse '/'
 222                                             & Doc.toBlock
 223                                         )
 224                                       , pag & Doc.pageSection & maybe [] Doc.toBlock
 225                                       ]
 226                                         & case pag & Doc.pageSide of
 227                                           Just Doc.PageSideLeft -> Doc.toBlock
 228                                           Just Doc.PageSideRight -> List.reverse >>> Doc.toBlock
 229                                           Nothing -> Doc.toBlock
 230                                   }
 231                               ]
 232                           }
 233                           & Doc.toBlock
 234                     }
 235                 ]
 236               ]
 237                 & mconcat
 238           }
 239 instance ToMarkup Block where
 240   toMarkup = \case
 241     BlockDiv x -> x & toMarkup
 242     BlockFlex x -> x & toMarkup
 243     BlockList x -> x & toMarkup
 244     BlockPara x -> p $ x & toMarkup
 245     BlockTable x -> x & toMarkup
 246     BlockDict x -> x & toMarkup
 247     Blocks xs -> xs & foldMap toMarkup
 248 instance ToMarkup Inline where
 249   toMarkup = \case
 250     InlineSpan x -> x & toMarkup
 251     InlineCode x -> code $ x & toMarkup
 252     InlineLink{inlineLinkText, inlineLinkTarget} ->
 253       ( if (inlineLinkTarget & unTarget & Doc.toInline) == inlineLinkText
 254           then a !? styles ["word-break" := "break-all"]
 255           else a
 256       )
 257         ! HA.href (inlineLinkTarget & unTarget & toValue)
 258         $ inlineLinkText & toMarkup
 259     InlineStrong x -> b $ x & toMarkup
 260     InlineText x -> x & toMarkup
 261     Inlines xs -> xs & foldMap toMarkup
 262 instance ToMarkup FlexItem where
 263   toMarkup itm =
 264     itm
 265       & flexItemContent
 266       & toMarkup
 267       & ( !?
 268             styles
 269               [ "justify-self" := itm & flexItemJustifySelf & toCSS
 270               , "align-self" := itm & flexItemAlignSelf & toCSS
 271               ]
 272         )
 273 instance ToMarkup (Container Block) where
 274   toMarkup cnt =
 275     (maybe elem (\anchor -> elem ! HA.id (anchor & toValue)) (cnt & containerAnchor))
 276       & (!? classes (cnt & containerClasses))
 277       $ cnt & containerContent & toMarkup
 278     where
 279       elem = case cnt & containerSemantic of
 280         Nothing -> div
 281         Just tag -> Parent (String.fromString t) (String.fromString ("<" <> t)) (String.fromString ("</" <> t <> ">"))
 282           where
 283             t = tag & unSemantic & Text.unpack
 284 instance ToMarkup (Container Inline) where
 285   toMarkup
 286     Container
 287       { containerAnchor = maybeId
 288       , containerClasses = cls
 289       , containerContent = x
 290       } =
 291       (maybe span (\anchor -> span ! HA.id (anchor & toValue)) maybeId) !? classes cls $
 292         x & toMarkup
 293 instance ToMarkup Flex where
 294   toMarkup flx =
 295     div
 296       !? styles
 297         [ "display" := "flex"
 298         , "flex-direction" := flx & flexDirection & toCSS
 299         , "gap" := flx & flexGap & toCSS
 300         , "align-content" := flx & flexAlignContent & toCSS
 301         , "align-items" := flx & flexAlignItems & toCSS
 302         , "justify-content" := flx & flexJustifyContent & toCSS
 303         , "justify-items" := flx & flexJustifyItems & toCSS
 304         , -- , "height" := "100%"
 305           -- FixMe(role): is it possible to avoid that to get the flex item to stretch?
 306           "width" := "100%"
 307         ]
 308       $ do
 309         forM_ (flx & flexItems) toMarkup
 310 instance ToMarkup List where
 311   toMarkup List{listItems} =
 312     div
 313       !? classes ["list"]
 314       !? styles
 315         [ "grid-template-columns" :=
 316             [ LengthRelative LengthRelativeMaxContent
 317             , LengthRelative $ 1 & fr
 318             ]
 319               <&> toCSS
 320               & List.unwords
 321         ]
 322       $ do
 323         forM_ (listItems & ol1) \(itemCount, (itemKey, itemValue)) -> do
 324           div !? classes ["list-body", if even itemCount then "even" else "odd"] $ do
 325             div
 326               !? classes ["list-key"]
 327               !? styles ["justify-items" := JustifyEnd & toCSS]
 328               $ do
 329                 itemKey & toMarkup
 330             div
 331               !? classes ["list-value"]
 332               !? styles ["justify-items" := JustifyStart & toCSS]
 333               $ do
 334                 itemValue & toMarkup
 335 instance ToMarkup Table where
 336   toMarkup tbl =
 337     div
 338       !? classes ["table"]
 339       !? styles ["grid-template-columns" := tbl & tableTemplateFinal <&> toCSS & List.unwords]
 340       $ do
 341         forM_ (tbl & tableHeads) \hd -> do
 342           div !? classes ["table-head"] $ do
 343             forM_ (hd & tableHeadColumns) \cel -> do
 344               div !? classes ["table-cell"] $ do
 345                 div do
 346                   cel & tableCellContent & toMarkup
 347         forM_ (tbl & tableRows & ol1) \(rowCount, row) -> do
 348           div !? classes ["table-body", if even rowCount then "even" else "odd"] $ do
 349             forM_ (row & tableRowColumns) \cel -> do
 350               div
 351                 !? classes ["table-cell"]
 352                 !? styles ["justify-items" := cel & tableCellJustify & toCSS]
 353                 !? styles ["align-items" := cel & tableCellAlign & toCSS]
 354                 $ do
 355                   cel & tableCellContent & toMarkup
 356 instance ToMarkup Dict where
 357   toMarkup dic =
 358     div
 359       !? classes ["dict"]
 360       $ do
 361         forM_ (dic & dictEntries) \(key, val) ->
 362           div !? classes ["dict-entry"] $ do
 363             div !? classes ["dict-key"] $ do
 364               key & toMarkup
 365               ":"
 366             -- "\x202F:"
 367             div !? classes ["dict-value"] $ do
 368               val & toMarkup