Hdoc/DTC/Write/HTML5/Base.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE ExistentialQuantification #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE FlexibleContexts #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeApplications #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Hdoc.DTC.Write.HTML5.Base where
  12
  13 import Control.Monad (Monad(..))
  14 import Data.Char (Char)
  15 import Data.Default.Class (Default(..))
  16 import Data.Either (Either(..))
  17 import Data.Foldable (Foldable(..))
  18 import Data.Function (($), (.))
  19 import Data.Functor ((<$>))
  20 import Data.Functor.Compose (Compose(..))
  21 import Data.Int (Int)
  22 import Data.Locale hiding (Index)
  23 import Data.Map.Strict (Map)
  24 import Data.Maybe (Maybe(..), maybe)
  25 import Data.Semigroup (Semigroup(..))
  26 import Data.String (String, IsString(..))
  27 import Data.Text (Text)
  28 import Prelude (mod)
  29 import Text.Show (Show(..))
  30 import qualified Control.Category as Cat
  31 import qualified Control.Monad.Trans.State as S
  32 import qualified Data.HashMap.Strict as HM
  33 import qualified Data.HashSet as HS
  34 import qualified Data.Text.Lazy as TL
  35 import qualified Data.TreeSeq.Strict as TreeSeq
  36 import qualified Hjugement as MJ
  37 import qualified Text.Blaze.Html5 as H
  38 import qualified Text.Blaze.Internal as H
  39
  40 import Hdoc.DTC.Document as DTC
  41 import Hdoc.DTC.Write.XML ()
  42 import qualified Text.Blaze.Internal as B
  43 -- import Text.Blaze.Utils
  44 import Control.Monad.Utils
  45 import qualified Hdoc.DTC.Check as Check
  46 import qualified Hdoc.DTC.Collect as Collect
  47 import qualified Hdoc.DTC.Index as Index
  48 import qualified Hdoc.DTC.Write.Plain as Plain
  49 import qualified Hdoc.XML as XML
  50
  51 -- * Type 'HTML5'
  52 type HTML5 = ComposeState State B.MarkupM ()
  53 instance IsString HTML5 where
  54         fromString = html5ify
  55
  56 -- ** Type 'Config'
  57 data Config =
  58  forall locales.
  59  ( Locales   locales
  60  , Loqualize locales (L10n HTML5)
  61  , Loqualize locales (Plain.L10n Plain.Plain)
  62  ) =>
  63  Config
  64  { config_css       :: Either FilePath TL.Text
  65  , config_js        :: Either FilePath TL.Text
  66  , config_locale    :: LocaleIn locales
  67  , config_generator :: TL.Text
  68  }
  69 instance Default Config where
  70         def = Config
  71          { config_css       = Right "style/dtc-html5.css"
  72          , config_js        = Right "style/dtc-html5.js"
  73          , config_locale    = LocaleIn @'[EN] en_US
  74          , config_generator = "https://hackage.haskell.org/package/hdoc"
  75          }
  76
  77 -- ** Type 'State'
  78 data State = State
  79  -- RW
  80  { state_styles    :: HS.HashSet (Either FilePath TL.Text)
  81  , state_scripts   :: HS.HashSet FilePath
  82  , state_notes     :: Check.NotesBySection
  83  , state_judgments :: HS.HashSet Judgment
  84  , state_opinions  :: HM.HashMap Judgment [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
  85  -- RO
  86  , state_section   :: TreeSeq.Trees BodyNode
  87  , state_collect   :: Collect.All
  88  , state_indexs    :: Map XML.Pos (Terms, Index.Irefs) -- TODO: could be a list
  89  , state_rrefs     :: HM.HashMap Ident [(Maybe Section,Nat1)]
  90  , state_plainify  :: Plain.State
  91  , state_l10n      :: Loqualization (L10n HTML5)
  92  }
  93 instance Default State where
  94         def = State
  95          { state_styles    = HS.fromList [Left "dtc-html5.css"]
  96          , state_scripts   = def
  97          , state_section   = def
  98          , state_collect   = def
  99          , state_indexs    = def
 100          , state_rrefs     = def
 101          , state_notes     = def
 102          , state_plainify  = def
 103          , state_l10n      = Loqualization EN_US
 104          , state_judgments = HS.empty
 105          , state_opinions  = def
 106          }
 107
 108 -- * Class 'Html5ify'
 109 class Html5ify a where
 110         html5ify :: a -> HTML5
 111 instance Html5ify H.Markup where
 112         html5ify = Compose . return
 113 instance Html5ify Char where
 114         html5ify = html5ify . H.toMarkup
 115 instance Html5ify Text where
 116         html5ify = html5ify . H.toMarkup
 117 instance Html5ify TL.Text where
 118         html5ify = html5ify . H.toMarkup
 119 instance Html5ify String where
 120         html5ify = html5ify . H.toMarkup
 121 instance Html5ify Ident where
 122         html5ify (Ident i) = html5ify i
 123 instance Html5ify Int where
 124         html5ify = html5ify . show
 125 instance Html5ify Name where
 126         html5ify (Name i) = html5ify i
 127 instance Html5ify Nat where
 128         html5ify (Nat n) = html5ify n
 129 instance Html5ify Nat1 where
 130         html5ify (Nat1 n) = html5ify n
 131 instance Html5ify a => Html5ify (Maybe a) where
 132         html5ify = foldMap html5ify
 133
 134 html5AttrClass :: [TL.Text] -> HTML5 -> HTML5
 135 html5AttrClass = \case
 136  [] -> Cat.id
 137  cls  ->
 138         Compose .
 139         (H.AddCustomAttribute "class"
 140          (H.String $ TL.unpack $ TL.unwords cls) <$>) .
 141         getCompose
 142
 143 html5AttrId :: Ident -> HTML5 -> HTML5
 144 html5AttrId (Ident id_) =
 145         Compose .
 146         (H.AddCustomAttribute "id"
 147          (H.String $ TL.unpack id_) <$>) .
 148         getCompose
 149
 150 html5CommonAttrs :: CommonAttrs -> HTML5 -> HTML5
 151 html5CommonAttrs CommonAttrs{id=id_, ..} =
 152         html5AttrClass classes .
 153         maybe Cat.id html5AttrId id_
 154
 155 -- * Class 'L10n'
 156 class
 157  ( Plain.L10n msg lang
 158  , Plain.L10n TL.Text lang
 159  ) => L10n msg lang where
 160         l10n_Header_Address :: FullLocale lang -> msg
 161         l10n_Header_Date    :: FullLocale lang -> msg
 162         l10n_Header_Version :: FullLocale lang -> msg
 163         l10n_Header_Origin  :: FullLocale lang -> msg
 164         l10n_Header_Source  :: FullLocale lang -> msg
 165         l10n_Errors_All                :: FullLocale lang -> Nat -> msg
 166         l10n_Error_Tag_unknown         :: FullLocale lang -> msg
 167         l10n_Error_Tag_ambiguous       :: FullLocale lang -> msg
 168         l10n_Error_Rref_unknown        :: FullLocale lang -> msg
 169         l10n_Error_Reference_ambiguous :: FullLocale lang -> msg
 170         l10n_Error_Judgment_Judges_unknown    :: FullLocale lang -> msg
 171         l10n_Error_Judgment_Judge_unknown     :: FullLocale lang -> msg
 172         l10n_Error_Judgment_Judge_duplicated  :: FullLocale lang -> msg
 173         l10n_Error_Judgment_Grades_unknown    :: FullLocale lang -> msg
 174         l10n_Error_Judgment_Grades_duplicated :: FullLocale lang -> msg
 175         l10n_Error_Judgment_Grade_unknown     :: FullLocale lang -> msg
 176         l10n_Error_Judgment_Choice_duplicated :: FullLocale lang -> msg
 177 instance L10n HTML5 EN where
 178         l10n_Header_Address _l10n = "Address"
 179         l10n_Header_Date    _l10n = "Date"
 180         l10n_Header_Origin  _l10n = "Origin"
 181         l10n_Header_Source  _l10n = "Source"
 182         l10n_Header_Version _l10n = "Version"
 183         l10n_Errors_All _l10n n = "All errors ("<>html5ify n<>")"
 184         l10n_Error_Tag_unknown         _l10n = "Unknown tag"
 185         l10n_Error_Tag_ambiguous       _l10n = "Ambiguous tag"
 186         l10n_Error_Rref_unknown        _l10n = "Unknown reference"
 187         l10n_Error_Reference_ambiguous _l10n = "Ambiguous reference"
 188         l10n_Error_Judgment_Judges_unknown    _l10n = "Unknown judges"
 189         l10n_Error_Judgment_Judge_unknown     _l10n = "Unknown judge"
 190         l10n_Error_Judgment_Judge_duplicated  _l10n = "Duplicated judge"
 191         l10n_Error_Judgment_Grades_unknown    _l10n = "Unknown grades"
 192         l10n_Error_Judgment_Grades_duplicated _l10n = "Duplicated grades"
 193         l10n_Error_Judgment_Grade_unknown     _l10n = "Unknown grade"
 194         l10n_Error_Judgment_Choice_duplicated _l10n = "Duplicated choice"
 195 instance L10n HTML5 FR where
 196         l10n_Header_Address _l10n = "Adresse"
 197         l10n_Header_Date    _l10n = "Date"
 198         l10n_Header_Origin  _l10n = "Origine"
 199         l10n_Header_Source  _l10n = "Source"
 200         l10n_Header_Version _l10n = "Version"
 201         l10n_Errors_All _l10n n = "Toutes les erreurs ("<>html5ify n<>")"
 202         l10n_Error_Tag_unknown         _l10n = "Tag inconnu"
 203         l10n_Error_Tag_ambiguous       _l10n = "Tag ambigu"
 204         l10n_Error_Rref_unknown        _l10n = "Référence inconnue"
 205         l10n_Error_Reference_ambiguous _l10n = "Référence ambiguë"
 206         l10n_Error_Judgment_Judges_unknown    _l10n = "Juges inconnu·es"
 207         l10n_Error_Judgment_Judge_unknown     _l10n = "Juge unconnu·e"
 208         l10n_Error_Judgment_Judge_duplicated  _l10n = "Juge en double"
 209         l10n_Error_Judgment_Grades_unknown    _l10n = "Mentions inconnues"
 210         l10n_Error_Judgment_Grades_duplicated _l10n = "Mentions en double"
 211         l10n_Error_Judgment_Grade_unknown     _l10n = "Mention inconnue"
 212         l10n_Error_Judgment_Choice_duplicated _l10n = "Choix en double"
 213
 214 instance Plain.L10n HTML5 EN where
 215         l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
 216         l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
 217         l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
 218         l10n_Quote msg _l10n = do
 219                 depth <- liftComposeState $ S.gets $ Plain.state_quote . state_plainify
 220                 let (o,c) :: (HTML5, HTML5) =
 221                         case unNat depth `mod` 3 of
 222                          0 -> ("“","”")
 223                          1 -> ("« "," »")
 224                          _ -> ("‟","„")
 225                 o
 226                 setDepth $ succNat depth
 227                 msg
 228                 setDepth $ depth
 229                 c
 230                 where
 231                 setDepth d =
 232                         liftComposeState $ S.modify' $ \s ->
 233                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
 234 instance Plain.L10n HTML5 FR where
 235         l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
 236         l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
 237         l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
 238         l10n_Quote msg _l10n = do
 239                 depth <- liftComposeState $ S.gets $ Plain.state_quote . state_plainify
 240                 let (o,c) :: (HTML5, HTML5) =
 241                         case unNat depth `mod` 3 of
 242                          0 -> ("« "," »")
 243                          1 -> ("“","”")
 244                          _ -> ("‟","„")
 245                 o
 246                 setDepth $ succNat depth
 247                 msg
 248                 setDepth $ depth
 249                 c
 250                 where
 251                 setDepth d =
 252                         liftComposeState $ S.modify' $ \s ->
 253                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}