src/Worksheets/Writing/Rosetta.hs

   1 module Worksheets.Writing.Rosetta where
   2
   3 import Data.ByteString.Builder (Builder)
   4 import Data.Char qualified as Char
   5 import Data.List qualified as List
   6 import Data.Map.Strict qualified as Map
   7 import Data.Set qualified as Set
   8 import Data.Text (Text)
   9 import Data.Text qualified as Text
  10 import Data.Text.Short qualified as ShortText
  11 import System.FilePath.Posix ((</>))
  12 import System.FilePath.Posix qualified as File
  13 import Text.Blaze
  14 import Text.Blaze.Html5 qualified as H
  15 import Text.Blaze.Html5.Attributes qualified as HA
  16 import Text.Blaze.Renderer.Utf8 qualified as Blaze
  17 import Prelude (error)
  18
  19 import Language.Chinese (ChineseDict (..), ChineseDictEntries (..))
  20 import Language.Chinese qualified
  21 import Paths_worksheets qualified as Self
  22 import Utils.Blaze
  23 import Worksheets.Prelude
  24
  25 data Langue
  26   = LangueFrançais
  27   | LangueAnglais
  28   | LangueMandarin
  29   | LangueMandarinPinyin
  30   | LanguePhonetic
  31   deriving (Eq, Ord, Show)
  32
  33 data RosettaPart = RosettaPart
  34   { rosettaPartPicture :: File.FilePath
  35   , rosettaPartDescription :: ShortText
  36   , rosettaPartText :: ShortText
  37   , rosettaPartLangue :: Langue
  38   }
  39   deriving (Eq, Ord, Show, Generic)
  40
  41 data Rosetta = Rosetta
  42   { rosettaParts :: [RosettaPart]
  43   , rosettaClasses :: [String]
  44   }
  45   deriving (Eq, Ord, Show, Generic)
  46   deriving (Semigroup, Monoid) via (Generically Rosetta)
  47
  48 lookupPinyins :: ChineseDict -> ShortText -> [ShortText]
  49 lookupPinyins (ChineseDict dict) word =
  50   word
  51     & (`Map.lookup` dict)
  52     & fromMaybe (error $ "lookupPinyins: no entry for: " <> wordString)
  53     & chinesePinyins
  54     & (\ps -> if null ps then error $ "lookupPinyins: empty entry for: " <> wordString else ps)
  55     & Set.elemAt 0 -- FIXME: how to choose?
  56   where
  57     wordString = word & ShortText.unpack
  58
  59 rosetta :: ChineseDict -> Text -> Rosetta -> IO Builder
  60 rosetta chineseDict title Rosetta{..} = do
  61   -- FIXME: this absolute path is not portable out of my system
  62   dataPath <- Self.getDataDir <&> File.normalise
  63   return $ Blaze.renderMarkupBuilder do
  64     H.docTypeHtml do
  65       H.head do
  66         H.title $ title & H.toHtml
  67         H.link
  68           ! HA.rel "stylesheet"
  69           ! HA.type_ "text/css"
  70           ! HA.href (toValue $ dataPath </> "styles/rosetta.css")
  71       H.body ! classes rosettaClasses $ do
  72         "\n"
  73         H.div ! classes ["rosetta"] $ do
  74           forM_ rosettaParts \RosettaPart{..} -> do
  75             -- pTraceShowM (rosettaPicture, RosettaEntry{..})
  76             "\n"
  77             H.div ! classes ["rosetta-row", "rosetta-row-" <> show rosettaPartLangue] $ do
  78               H.div ! classes ["rosetta-cell", "rosetta-cell-picture"] $ do
  79                 unless (ShortText.null rosettaPartDescription) do
  80                   H.span ! classes ["rosetta-cell-picture-description"] $ do
  81                     rosettaPartDescription & H.toHtml
  82                 H.img ! HA.src ("file://" <> dataPath </> "images" </> rosettaPartPicture & toValue)
  83               H.div ! classes ["rosetta-cell", "rosetta-cell-words"] $ do
  84                 let cellSpace = \case
  85                       ' ' -> "writing-words-cell-space"
  86                       _ -> ""
  87                 H.div ! classes ["writing-words"] $ do
  88                   forM_ (rosettaPartText & ShortText.split (== ' ')) \writingWord -> do
  89                     let wordLength = writingWord & ShortText.length
  90                     let needsDict w = w & ShortText.unpack & any \c -> not (Char.isPunctuation c)
  91                     let charWidth = case rosettaPartLangue of
  92                           LangueMandarin -> "1.5cm"
  93                           _
  94                             | wordLength > (if List.elem "landscape" rosettaClasses then 14 else 17) -> "0.75cm"
  95                             | otherwise -> "1cm"
  96                     H.div
  97                       ! classes
  98                         [ "writing-words-word"
  99                         ]
 100                       $ do
 101                         when (rosettaPartLangue == LangueMandarin) do
 102                           H.div
 103                             ! classes
 104                               [ "writing-words-row"
 105                               , "writing-words-" <> show LangueMandarinPinyin
 106                               ]
 107                             ! HA.style ("grid-template-columns: repeat(" <> show wordLength <> ", " <> charWidth <> ");" & toValue)
 108                             $ do
 109                               let
 110                                 pinyins :: [ShortText]
 111                                 pinyins
 112                                   | writingWord & ShortText.unpack & all Char.isNumber =
 113                                       [ writingChar & ShortText.singleton & lookupPinyins chineseDict
 114                                       | writingChar <- writingWord & ShortText.unpack
 115                                       ]
 116                                         & mconcat
 117                                   | needsDict writingWord = writingWord & lookupPinyins chineseDict
 118                                   | otherwise = List.repeat " "
 119                               forM_
 120                                 (List.zip (writingWord & ShortText.unpack) pinyins)
 121                                 \(writingChar, writingPinyin) -> do
 122                                   H.div ! classes ["writing-words-cell", cellSpace writingChar] $ do
 123                                     writingPinyin
 124                                       & Language.Chinese.numberedPinyinToDiacriticPiniyn
 125                                       & ShortText.toText
 126                                       & Text.toLower
 127                                       & H.toHtml
 128                         H.div
 129                           ! classes
 130                             [ "writing-words-row"
 131                             , "writing-words-" <> show rosettaPartLangue
 132                             , "writing-words-row-model"
 133                             ]
 134                           ! HA.style ("grid-template-columns: repeat(" <> show wordLength <> ", " <> charWidth <> ");" & toValue)
 135                           $ do
 136                             forM_ (writingWord & ShortText.unpack) \writingChar -> do
 137                               H.div ! classes ["writing-words-cell", cellSpace writingChar] $ do
 138                                 fromString [writingChar]
 139                         "\n"
 140                         H.div
 141                           ! classes
 142                             [ "writing-words-row"
 143                             , "writing-words-" <> show rosettaPartLangue
 144                             , "writing-words-row-input"
 145                             ]
 146                           ! HA.style ("grid-template-columns: repeat(" <> show wordLength <> ", " <> charWidth <> ");" & toValue)
 147                           $ do
 148                             forM_ (writingWord & ShortText.unpack) \writingChar -> do
 149                               H.div ! classes ["writing-words-cell", cellSpace writingChar] $ do
 150                                 case rosettaPartLangue of
 151                                   LangueMandarin -> fromString [writingChar]
 152                                   _ -> " "
 153                         "\n"
 154                   "\n"