src/Book/Writing.hs

   1 {-# LANGUAGE OverloadedLists #-}
   2
   3 module Book.Writing where
   4
   5 -- import Data.Char qualified as Char
   6 -- import Data.Set qualified as Set
   7 -- import Control.Monad.Trans.State qualified as MT
   8 -- import Control.Monad.Trans.Class qualified as MT
   9 import Dataa.ByteString.Builder (Builder)
  10 import Data.List qualified as List
  11 import Data.Map.Strict qualified as Map
  12 import Data.Text qualified as Text
  13 import Data.Text.Short qualified as ShortText
  14 import System.FilePath.Posix ((</>))
  15 import System.FilePath.Posix qualified as File
  16 import Text.Blaze
  17 import Text.Blaze.Html5 qualified as HTML
  18 import Text.Blaze.Html5.Attributes qualified as HA
  19 import Text.Blaze.Renderer.Utf8 qualified as Blaze
  20 import Prelude (error)
  21
  22 import Language
  23 import Language.Chinese (ChineseDict (..), ChineseDictEntries (..))
  24 import Language.Chinese qualified as Chinese
  25 import Language.English qualified as English
  26 import Language.French qualified as French
  27 import Language.Pronunciation as Pron
  28 import Paths_worksheets qualified as Self
  29 import Rosetta.Reading qualified as Reading
  30 import Worksheets.Utils.Char as Char
  31 import Worksheets.Utils.HTML (className, classes, fr, styles)
  32 import Worksheets.Utils.HTML qualified as HTML
  33 import Worksheets.Utils.Paper
  34 import Worksheets.Utils.Prelude
  35
  36 type Difficulties = Map UnicodeBlock Difficulty
  37 data Difficulty = Difficulty
  38   { difficultyReading :: Reading.Difficulty
  39   , difficultyModel :: Bool
  40   , difficultyHiddenPatterns :: Bool
  41   }
  42   deriving (Eq, Show, Generic)
  43 instance HasTypeDefault Difficulty where
  44   typeDefault =
  45     Difficulty
  46       { difficultyReading = typeDefault
  47       , difficultyModel = True
  48       , difficultyHiddenPatterns = False
  49       }
  50
  51 data Part = Part
  52   { partPicture :: File.FilePath
  53   , partPictureCSS :: HTML.CSSBlock
  54   , partDescription :: ShortText
  55   , partText :: [Either Lexeme Text]
  56   , partLangue :: Langue
  57   }
  58   deriving (Eq, Show, Generic)
  59   deriving (HasTypeDefault) via (Generically Part)
  60
  61 data Page = Page
  62   { pageParts :: [Part]
  63   , pageColumnPictureWidth :: HTML.Length
  64   , pageColumnTextWidth :: HTML.Length
  65   , pageSize :: PageSize
  66   , pageOrientation :: PageOrientation
  67   , pageDifficulties :: Difficulties
  68   }
  69   deriving (Eq, Show, Generic)
  70
  71 instance HasTypeDefault Page where
  72   typeDefault =
  73     Page
  74       { pageParts = []
  75       , pageColumnPictureWidth = 1 & fr
  76       , pageColumnTextWidth = 1 & fr
  77       , pageSize = typeDefault
  78       , pageOrientation = typeDefault
  79       , pageDifficulties = Char.unicodeBlocks & Map.fromSet (const typeDefault)
  80       }
  81
  82 pagePortrait m =
  83   m
  84     { pageOrientation = PageOrientationPortrait
  85     , pageColumnPictureWidth = 3 & fr
  86     , pageColumnTextWidth = 4 & fr
  87     }
  88 pageLandscape m =
  89   m
  90     { pageOrientation = PageOrientationLandscape
  91     , pageColumnPictureWidth = 1 & fr
  92     , pageColumnTextWidth = 2 & fr
  93     }
  94
  95 pageHTML :: ChineseDict -> Text -> Page -> IO Builder
  96 pageHTML chineseDict title Page{..} = do
  97   -- FIXME: this absolute path is not portable out of my system
  98   dataPath <- Self.getDataDir <&> File.normalise
  99   return $ Blaze.renderMarkupBuilder do
 100     HTML.docTypeHtml do
 101       HTML.head do
 102         HTML.title $ title & HTML.toHtml
 103         forM_
 104           ( [ "styles/Paper.css"
 105             , "styles/Rosetta/Common.css"
 106             , "styles/Rosetta/Writing.css"
 107             ]
 108               & list
 109           )
 110           \cssFile ->
 111             HTML.link
 112               ! HA.rel "stylesheet"
 113               ! HA.type_ "text/css"
 114               ! HA.href (dataPath </> cssFile & toValue)
 115         HTML.styleCSS $ HTML.cssPrintPage pageOrientation pageSize
 116         HTML.styleCSS $ pageDifficulties <&> difficultyReading & Reading.difficultyCSS
 117       HTML.body
 118         ! classes
 119           [ "A4"
 120           , case pageOrientation of
 121               PageOrientationPortrait -> "portrait"
 122               PageOrientationLandscape -> "landscape"
 123           ]
 124         $ do
 125           "\n"
 126           let numOfParts = pageParts & List.length
 127           HTML.section
 128             ! classes
 129               [ "rosetta-writing"
 130               , "sheet"
 131               ]
 132             ! styles
 133               [ "grid-template-columns" := [pageColumnPictureWidth, pageColumnTextWidth] <&> HTML.toCSS & List.unwords
 134               , "grid-template-rows" := "1fr" & List.replicate numOfParts & List.unwords
 135               ]
 136             $ do
 137               forM_ pageParts \Part{..} -> do
 138                 "\n"
 139                 HTML.div
 140                   ! classes
 141                     [ "rosetta-writing-part"
 142                     , "rosetta-writing-part-picture"
 143                     , if partDescription & ShortText.null then "" else "with-description"
 144                     ]
 145                   $ do
 146                     HTML.img
 147                       ! styles partPictureCSS
 148                       ! HA.src ("file://" <> dataPath </> "images" </> partPicture & toValue)
 149                     unless (partDescription & ShortText.null) do
 150                       HTML.span ! classes ["description"] $ do
 151                         partDescription & HTML.toHtml
 152                 HTML.div ! classes ["rosetta-writing-part", "sentence"] $ do
 153                   -- traceShowM ("partText"::Text, partText)
 154                   -- forM_ (partText & rosettaTokenizer & groupByHoriz) \writingHoriz -> do
 155                   --   "\n"
 156                   --   traceShowM ("writingHoriz"::Text, writingHoriz)
 157                   -- HTML.div ! classes ["sentence-horiz"] $ do
 158                   -- forM_ (writingHoriz & splitWords) \writingWord -> do
 159                   -- let writingWord :: Text = "choux hibou genoux caillou glace"
 160                   -- traceShowM ("writingWord"::String, writingWord)
 161                   let textToSoundsGroup =
 162                         partText
 163                           & case partLangue of
 164                             LangueMandarin -> Chinese.pronunciation chineseDict
 165                             LangueFrançais -> French.pronunciation
 166                             LangueAnglais -> English.pronunciation
 167                             _ -> error $ "partLangue unsupported: " <> show partLangue
 168                   let addIndexes (idx :: Int) = \case
 169                         [] -> []
 170                         lexs : t -> List.reverse lexs' : addIndexes idx' t
 171                           where
 172                             (idx', lexs') =
 173                               List.foldl'
 174                                 ( \(i, is) kv@(_key, lex) ->
 175                                     case lex & lexemePronunciation of
 176                                       PronunciationSilent -> (i, (i, kv) : is)
 177                                       PronunciationIPABroad{} -> (i + 1, (i + 1, kv) : is)
 178                                 )
 179                                 (idx, [])
 180                                 lexs
 181                   let isBreak c =
 182                         c
 183                           == Pron.borderLeftChar
 184                           || c
 185                           == Pron.borderRightChar
 186                   forM_ (textToSoundsGroup & addIndexes 0) \textToSounds -> do
 187                     HTML.div ! classes ["sentence-horiz"] $ do
 188                       let addWordIndexes (idx :: Int) = \case
 189                             [] -> []
 190                             (textIndex, (textChunk, textLexeme)) : t ->
 191                               (idx, (textIndex, (textChunk, textLexeme))) : addWordIndexes idx' t
 192                               where
 193                                 idx'
 194                                   | textChunk == Text.singleton Pron.borderLeftChar = idx
 195                                   | textChunk == Text.singleton Pron.borderRightChar = idx
 196                                   | otherwise = idx + 1
 197                       forM_ (textToSounds & addWordIndexes 0) \(wordIndex, (textIndex, (textChunk, LexemePron{..}))) -> do
 198                         let addCharIndexes (idx :: Int) = \case
 199                               [] -> []
 200                               c : cs -> (idx', c) : addCharIndexes idx' cs
 201                                 where
 202                                   idx' =
 203                                     case c & charMetaUnicodeCategory of
 204                                       Char.Space -> idx
 205                                       _
 206                                         | isBreak (charMetaChar c) -> idx
 207                                         | otherwise -> idx + 1
 208                         let charsMeta = textChunk & metanizer & addCharIndexes 0
 209                         HTML.div
 210                           ! classes
 211                             [ "sentence-word"
 212                             , "word-index-" <> show wordIndex
 213                             , "lang-" <> className partLangue
 214                             ]
 215                           ! styles
 216                             [ "grid-template-columns" :=
 217                                 "repeat("
 218                                   <> (charsMeta & List.length & show)
 219                                   <> ",auto)"
 220                             ]
 221                           $ do
 222                             HTML.div
 223                               ! classes
 224                                 [ "sentence-cell"
 225                                 , "pronunciation"
 226                                 , -- , "cell-index-"<>show textIndex
 227                                   "cell-" <> case lexemePronunciation of
 228                                     PronunciationSilent -> "silent"
 229                                     PronunciationIPABroad{} -> if even textIndex then "even" else "odd"
 230                                 ]
 231                               ! styles
 232                                 [ "grid-column-end" := "span " <> show (textChunk & Text.length)
 233                                 -- , "display" := if partLangue == LangueAnglais then "none" else ""
 234                                 ]
 235                               $ do
 236                                 HTML.toHtml $ case lexemePronunciation of
 237                                   PronunciationSilent -> ""
 238                                   PronunciationIPABroad txt _examples -> txt
 239                             forM_ charsMeta \(_charIndex, charMeta) -> do
 240                               let uniScript = charMeta & charMetaUnicodeBlock & fromMaybe (UnicodeBlockLatin UnicodeBlockLatin_Basic)
 241                               HTML.span
 242                                 ! classes
 243                                   [ "sentence-cell"
 244                                   , "model"
 245                                   , "script-" <> className uniScript
 246                                   , if pageDifficulties
 247                                       & lookupOrTypeDefault uniScript
 248                                       & difficultyModel
 249                                       then mempty
 250                                       else "hidden"
 251                                   , if isBreak $ charMetaChar charMeta
 252                                       then "break"
 253                                       else "non-break"
 254                                   ]
 255                                 $ do
 256                                   HTML.span ! classes ["cell"] $ do
 257                                     charMeta & charMetaChar & HTML.toHtml
 258                             forM_ charsMeta \(charIndex, charMeta) -> do
 259                               let uniScript = charMeta & charMetaUnicodeBlock & fromMaybe (UnicodeBlockLatin UnicodeBlockLatin_Basic)
 260                               HTML.span
 261                                 ! classes
 262                                   [ "sentence-cell"
 263                                   , "input"
 264                                   , "input-index-" <> show charIndex
 265                                   , "script-" <> className uniScript
 266                                   , if pageDifficulties
 267                                       & lookupOrTypeDefault uniScript
 268                                       & difficultyHiddenPatterns
 269                                       then "hidden"
 270                                       else ""
 271                                   , if isBreak $ charMetaChar charMeta
 272                                       then "break"
 273                                       else "non-break"
 274                                   ]
 275                                 $ do
 276                                   HTML.span ! classes ["cell"] $ do
 277                                     charMeta & charMetaChar & HTML.toHtml