src/Rosetta/Reading.hs

   1 {-# LANGUAGE OverloadedLists #-}
   2
   3 module Rosetta.Reading where
   4
   5 import Data.ByteString.Builder (Builder)
   6
   7 -- import Data.Char qualified as Char
   8 import Data.List qualified as List
   9 import Data.Map.Strict qualified as Map
  10
  11 -- import Data.Set qualified as Set
  12 import Data.Text qualified as Text
  13
  14 -- import Data.Text.Short qualified as ShortText
  15 import System.FilePath.Posix ((</>))
  16 import System.FilePath.Posix qualified as File
  17 import Text.Blaze
  18 import Text.Blaze.Html5 qualified as HTML
  19 import Text.Blaze.Html5.Attributes qualified as HA
  20 import Text.Blaze.Renderer.Utf8 qualified as Blaze
  21 import Prelude (div, even)
  22
  23 import Language
  24 import Language.Chinese (ChineseDict (..), ChineseDictEntries (..))
  25 import Language.Chinese qualified
  26 import Language.Chinese qualified as Chinese
  27 import Language.English qualified as English
  28 import Language.French qualified as French
  29 import Language.Pronunciation as Pron
  30 import Paths_worksheets qualified as Self
  31 import Worksheets.Utils.Char as Char
  32 import Worksheets.Utils.HTML (Length, className, classes, cm, fr, styles)
  33 import Worksheets.Utils.HTML qualified as HTML
  34 import Worksheets.Utils.IPA qualified as IPA
  35 import Worksheets.Utils.Paper
  36 import Worksheets.Utils.Prelude
  37
  38 type Difficulties = Map Langue (Map UnicodeBlock Difficulty)
  39 data Difficulty = Difficulty
  40   { difficultyCharWidth :: Length
  41   , difficultyCharHeight :: Length
  42   , difficultyWordSpacing :: Length
  43   , difficultyFontSize :: Length
  44   , difficultyColor :: Text
  45   }
  46   deriving (Eq, Show, Generic)
  47 instance HasTypeDefault Difficulty where
  48   typeDefault =
  49     Difficulty
  50       { difficultyCharWidth = 1 & cm
  51       , difficultyCharHeight = 1 & cm
  52       , difficultyWordSpacing = 0.5 & cm
  53       , difficultyFontSize = 1 & cm
  54       , difficultyColor = "#000000"
  55       }
  56
  57 difficultyBig :: Char.UnicodeBlock -> Modifier Difficulty
  58 difficultyBig ub v = case ub of
  59   Char.UnicodeBlockLatin{} ->
  60     v
  61       { difficultyCharWidth = 1 & cm
  62       , difficultyCharHeight = 1 & cm
  63       , difficultyWordSpacing = 0.5 & cm
  64       , difficultyFontSize = 0.90 & cm
  65       }
  66   Char.UnicodeBlockCJK{} ->
  67     v
  68       { difficultyCharWidth = 1.50 & cm
  69       , difficultyCharHeight = 1.50 & cm
  70       , difficultyWordSpacing = 0.5 & cm
  71       , difficultyFontSize = 1.40 & cm
  72       }
  73   Char.UnicodeBlockHalfwidth_and_Fullwidth_Forms{} ->
  74     v
  75       { difficultyCharWidth = 1.50 & cm
  76       , difficultyCharHeight = 1.50 & cm
  77       , difficultyWordSpacing = 0.5 & cm
  78       , difficultyFontSize = 1.40 & cm
  79       }
  80   _ -> v
  81
  82 data Part = Part
  83   { partText :: InputLexemes
  84   , partLangue :: Langue
  85   }
  86   deriving (Eq, Show, Generic)
  87   deriving (HasTypeDefault) via (Generically Part)
  88
  89 data Card = Card
  90   { cardParts :: [Part]
  91   , cardDescription :: Text
  92   , cardPicture :: File.FilePath
  93   , cardPictureCSS :: HTML.CSSBlock
  94   }
  95   deriving (Eq, Show, Generic)
  96
  97 instance HasTypeDefault Card where
  98   typeDefault =
  99     Card
 100       { cardPicture = ""
 101       , cardDescription = ""
 102       , cardPictureCSS = mempty
 103       , cardParts = []
 104       }
 105
 106 data Page = Page
 107   { pageCards :: [Card]
 108   , pageCardsColumns :: Int -- = 8
 109   , pageCardsRows :: Int -- = 8
 110   , pageSize :: PageSize
 111   , pageCardWidth :: Length
 112   , pageCardHeight :: Length
 113   , pageOrientation :: PageOrientation
 114   }
 115   deriving (Eq, Show, Generic)
 116 instance HasTypeDefault Page where
 117   typeDefault =
 118     Page
 119       { pageCards = mempty
 120       , pageCardsColumns = 4
 121       , pageCardsRows = 2
 122       , pageSize = typeDefault
 123       , pageCardWidth = 6.3 & cm
 124       , pageCardHeight = 8.8 & cm
 125       , pageOrientation = typeDefault
 126       }
 127
 128 data Pages = Pages
 129   { pagesList :: [Page]
 130   , pagesDifficulties :: Difficulties
 131   }
 132   deriving (Eq, Show, Generic)
 133 instance HasTypeDefault Pages where
 134   typeDefault =
 135     Pages
 136       { pagesList = []
 137       , pagesDifficulties =
 138           [ lang :=
 139             [ block := typeDefault
 140             | block <- Char.unicodeBlocks & toList
 141             ]
 142               & Map.fromList
 143           | lang <- langues & toList
 144           ]
 145             & Map.fromList
 146       }
 147
 148 data Dicts = Dicts
 149   { dictsChinese :: Chinese.ChineseDict
 150   , dictsFrench :: Pron.Table
 151   , dictsEnglish :: Pron.Table
 152   }
 153
 154 pagesHTML :: Dicts -> Text -> Pages -> IO Builder
 155 pagesHTML Dicts{..} title Pages{..} = do
 156   -- FIXME: this absolute path is not portable out of my system
 157   dataPath <- Self.getDataDir <&> File.normalise
 158   return $ Blaze.renderMarkupBuilder do
 159     HTML.docTypeHtml do
 160       HTML.head do
 161         HTML.title $ title & HTML.toHtml
 162         forM_
 163           ( [ "styles/Paper.css"
 164             , "styles/Rosetta/Common.css"
 165             , "styles/Rosetta/Reading.css"
 166             ]
 167               & list
 168           )
 169           \cssFile ->
 170             HTML.link
 171               ! HA.rel "stylesheet"
 172               ! HA.type_ "text/css"
 173               ! HA.href (dataPath </> cssFile & toValue)
 174         -- styleCSS $ cssPrintPage pageOrientation pageSize
 175         HTML.styleCSS $ pagesDifficulties & difficultyCSS
 176       HTML.body do
 177         forM_ pagesList \Page{..} -> do
 178           "\n"
 179           let pageCardsNum = pageCardsColumns * pageCardsRows
 180           forM_ (pageCards & chunksOf pageCardsNum) \cardsGiven -> do
 181             let cards = cardsGiven & (<> List.repeat typeDefault) & List.take pageCardsNum
 182             let forPageCards cardType cardsForPage k = do
 183                   HTML.section
 184                   ! classes
 185                     [ "rosetta-reading"
 186                     , "A4"
 187                     , "sheet"
 188                     , pageOrientation & HTML.cssPageOrientation
 189                     ]
 190                   ! styles
 191                     [ "size" :=
 192                         List.unwords
 193                           [ pageSize & HTML.cssPageSize
 194                           , pageOrientation & HTML.cssPageOrientation
 195                           ]
 196                     ]
 197                   $ do
 198                     "\n"
 199                     HTML.div
 200                       ! classes
 201                         [ "cards"
 202                         , "cards-" <> cardType
 203                         ]
 204                       ! styles
 205                         [ "grid-template-columns" := "repeat(" <> show pageCardsColumns <> "," <> HTML.toCSS pageCardWidth <> ")"
 206                         , "grid-template-rows" := "repeat(" <> show pageCardsRows <> "," <> HTML.toCSS pageCardHeight <> ")"
 207                         ]
 208                       $ do
 209                         forM_ cardsForPage \card_ -> do
 210                           "\n"
 211                           HTML.div
 212                             ! classes
 213                               [ "card"
 214                               , "card-" <> cardType
 215                               ]
 216                             $ do
 217                               k card_
 218             -- ExplanationNote: short-edge binding, enable recto and verso to have the same bottom and top margins
 219             let organize = case pageOrientation :: PageOrientation of
 220                   PageOrientationPortrait -> List.concatMap List.reverse
 221                   PageOrientationLandscape -> List.concatMap List.reverse
 222             forPageCards "front" (cards & chunksOf pageCardsColumns & organize) \Card{..} -> do
 223               forM_ cardParts \Part{..} -> do
 224                 {-
 225                 HTML.div
 226                   ! classes
 227                     [ "word"
 228                     , "lang-" <> className wordLangue
 229                     -- , "script-" <> className uniScript
 230                     ]
 231                   $ do
 232                     let classEven i = if even i then "part-even" else "part-odd"
 233                     HTML.div ! classes ["word-field", "word-parts"] $ do
 234                       (\f -> foldM_ f (0 :: Int) wordParts) \i Part{..} -> do
 235                         HTML.span ! classes ["word-part", classEven i, "word-part-" <> show partSyllabs] $ do
 236                           forM_ (partText & ShortText.unpack) \char -> do
 237                             HTML.span ! classes ["word-char"] $ do
 238                               char & HTML.toHtml
 239                         return
 240                           $ if partSyllabs == 1
 241                             then i + 1
 242                             else i
 243                     unless (wordIPABroad & null) do
 244                       HTML.div ! classes ["word-field", "word-ipas", "word-ipas-broad"] $ do
 245                         forM_ (wordIPABroad & List.zip [0 :: Int ..]) \(i, ipa) -> do
 246                           HTML.span ! classes ["word-ipa-broad", "word-ipa", classEven i] $ do
 247                             ipa & HTML.toHtml
 248                     unless (wordPinyin & null) do
 249                       HTML.div ! classes ["word-field", "word-pinyins"] $ do
 250                         forM_ (wordPinyin & List.zip [0 :: Int ..]) \(i, pinyin) -> do
 251                           HTML.span ! classes ["word-pinyin", classEven i] $ do
 252                             pinyin & HTML.toHtml
 253                 -}
 254                 HTML.div
 255                   ! classes
 256                     [ "card-matter"
 257                     , "sentence"
 258                     , "lang-" <> className partLangue
 259                     ]
 260                   $ do
 261                     let textToSoundsGroup :: [[Either Char Pron.Pron]] =
 262                           case partLangue of
 263                             LangueAnglais ->
 264                               partText
 265                                 & Pron.unInputLexemes
 266                                 & Pron.runParser dictsEnglish
 267                                 & either errorShow id
 268                                 & Pron.words
 269                             LangueFrançais ->
 270                               partText
 271                                 & Pron.unInputLexemes
 272                                 & Pron.runParser dictsFrench
 273                                 & either errorShow id
 274                                 & Pron.words
 275                             LangueMandarin ->
 276                               partText
 277                                 & Pron.unInputLexemes
 278                                 & Chinese.pronunciation dictsChinese
 279                             _ -> errorShow ("partLangue unsupported" :: Text, partLangue)
 280                     forM_ (textToSoundsGroup & Pron.addIndexes) \textToSounds -> do
 281                       HTML.div ! classes ["sentence-horiz"] $ do
 282                         forM_ textToSounds \syl@Syl{..} -> do
 283                           HTML.div
 284                             ! classes
 285                               [ "sentence-word"
 286                               ]
 287                             ! styles
 288                               [ "grid-template-columns" :=
 289                                   "repeat("
 290                                     <> (sylText & Text.length & show)
 291                                     <> ",auto)"
 292                               ]
 293                             $ do
 294                               let sylSoundsSpan = sylText & Text.length
 295                               let sylSoundParts = sylSound & Text.words & \l -> if null l then [""] else l
 296                               let sylSounsSpanRest = sylSoundsSpan - List.length sylSoundParts + 1
 297                               forM_ (sylSoundParts & List.zip (sylSounsSpanRest : List.repeat 1)) \(sylSoundSpan, sylSoundPart) -> do
 298                                 HTML.div
 299                                   ! classes
 300                                     [ "sentence-cell"
 301                                     , "pronunciation"
 302                                     , "cell-" <> case syl of
 303                                         Pron.Syl{sylSilent = True} -> "silent"
 304                                         Pron.Syl{sylIndex = i} -> if i & even then "even" else "odd"
 305                                     , if sylDependsOnAfter then "cell-depends-on-after" else ""
 306                                     , if sylDependsOnBefore then "cell-depends-on-before" else ""
 307                                     , if sylDependsOnMeaning then "cell-depends-on-meaning" else ""
 308                                     , if sylSplit then "cell-split" else ""
 309                                     ]
 310                                   ! styles
 311                                     [ "grid-column-end" := "span " <> show sylSoundSpan
 312                                     ]
 313                                   $ do
 314                                     HTML.toHtml sylSoundPart
 315                               forM_ (sylText & Text.unpack) \pronChar -> do
 316                                 let uniScript = pronChar & Char.unicodeBlock & fromMaybe (UnicodeBlockLatin UnicodeBlockLatin_Basic)
 317                                 HTML.span
 318                                   ! classes
 319                                     [ "sentence-cell"
 320                                     , "model"
 321                                     , "script-" <> className uniScript
 322                                     ]
 323                                   $ do
 324                                     HTML.span ! classes ["cell"] $ do
 325                                       pronChar & HTML.toHtml
 326                 unless (cardDescription & Text.null) do
 327                   HTML.div
 328                     ! classes
 329                       [ "card-description"
 330                       ]
 331                     $ do
 332                       cardDescription & HTML.toHtml
 333             forPageCards "back" cards \Card{..} -> do
 334               HTML.div
 335                 ! classes
 336                   [ "card-picture"
 337                   ]
 338                 $ do
 339                   unless (null cardPicture) do
 340                     HTML.img
 341                       ! styles cardPictureCSS
 342                       ! HA.title (cardPicture & toValue)
 343                       ! HA.src ("file://" <> dataPath </> "images" </> cardPicture & toValue)
 344
 345 pagePortrait m =
 346   m
 347     { pageOrientation = PageOrientationPortrait
 348     }
 349 pageLandscape m =
 350   m
 351     { pageOrientation = PageOrientationLandscape
 352     }
 353
 354 difficultyCSS :: Difficulties -> HTML.CSS
 355 difficultyCSS diffs =
 356   [ [ [ [".lang-" <> show lang <> " " <> ".script-" <> className uniScript] :=
 357           [ "width" := difficultyCharWidth & HTML.toCSS
 358           , "height" := difficultyCharHeight & HTML.toCSS
 359           , "font-size" := difficultyFontSize & HTML.toCSS
 360           , "color" := difficultyColor & HTML.toCSS
 361           ]
 362       , [ ".lang-" <> show lang <> ".sentence"
 363         ]
 364           := ["column-gap" := difficultyWordSpacing & HTML.toCSS]
 365       ]
 366     | (uniScript, Difficulty{..}) <- blocks & toList
 367     ]
 368   | (lang, blocks) <- diffs & Map.toList
 369   ]
 370     & mconcat
 371     & fromList
 372     & mconcat