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