src/Rosetta/Writing.hs

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