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.Bool
  15 import Data.Char (Char)
  16 import Data.Default.Class (Default(..))
  17 import Data.Either (Either(..))
  18 import Data.Foldable (Foldable(..))
  19 import Data.Function (($), (.), id)
  20 import Data.Functor ((<$>))
  21 import Data.Functor.Compose (Compose(..))
  22 import Data.Int (Int)
  23 import Data.Locale hiding (Index)
  24 import Data.Maybe (Maybe(..), maybe)
  25 import Data.Monoid (Monoid(..))
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.Sequence (Seq)
  28 import Data.String (String, IsString(..))
  29 import Data.Text (Text)
  30 import Prelude (mod)
  31 import Text.Show (Show(..))
  32 import qualified Control.Monad.Trans.RWS.Strict as RWS
  33 import qualified Data.HashMap.Strict as HM
  34 import qualified Data.HashSet as HS
  35 import qualified Data.Text.Lazy as TL
  36 import qualified Data.TreeMap.Strict as TM
  37 import qualified Data.TreeSeq.Strict as TS
  38 import qualified Majority.Judgment as MJ
  39 import qualified Text.Blaze.Html5 as H
  40 import qualified Text.Blaze.Internal as H
  41
  42 import Control.Monad.Utils
  43 import Hdoc.Utils ()
  44 import Hdoc.DTC.Document as DTC
  45 import Hdoc.DTC.Write.XML ()
  46 import qualified Hdoc.DTC.Analyze.Check   as Analyze
  47 import qualified Hdoc.DTC.Analyze.Collect as Analyze
  48 import qualified Hdoc.DTC.Analyze.Index   as Analyze
  49 import qualified Hdoc.DTC.Write.Plain as Plain
  50 import qualified Text.Blaze.Internal as B
  51
  52 -- * Type 'HTML5'
  53 type HTML5 = ComposeRWS Reader Writer State B.MarkupM ()
  54 instance IsString HTML5 where
  55         fromString = html5ify
  56
  57 -- ** Type 'Config'
  58 data Config =
  59  forall locales.
  60  ( Locales   locales
  61  , Loqualize locales (L10n HTML5)
  62  , Loqualize locales (Plain.L10n Plain.Plain)
  63  ) =>
  64  Config
  65  { config_css       :: Either FilePath TL.Text
  66  , config_js        :: Either FilePath TL.Text
  67  , config_locale    :: LocaleIn locales
  68  , config_generator :: TL.Text
  69  }
  70 instance Default Config where
  71         def = Config
  72          { config_css       = Right "style/dtc-html5.css"
  73          , config_js        = Right "" -- "style/dtc-html5.js"
  74          , config_locale    = LocaleIn @'[EN] en_US
  75          , config_generator = "https://hackage.haskell.org/package/hdoc"
  76          }
  77
  78 -- ** Type 'Reader'
  79 data Reader = Reader
  80  { reader_l10n     :: Loqualization (L10n HTML5)
  81  , reader_plainify :: Plain.Reader
  82  , reader_italic   :: Bool
  83  , reader_all      :: Analyze.All
  84  , reader_section  :: TS.Trees BodyNode
  85  }
  86 instance Default Reader where
  87         def = Reader
  88          { reader_l10n     = Loqualization EN_US
  89          , reader_plainify = def
  90          , reader_italic   = False
  91          , reader_all      = def
  92          , reader_section  = def
  93          }
  94
  95 -- ** Type 'Writer'
  96 data Writer = Writer
  97  { writer_scripts :: HS.HashSet FilePath
  98  , writer_styles  :: HS.HashSet (Either FilePath TL.Text)
  99  }
 100 instance Default Writer where
 101         def = Writer
 102          { writer_scripts = def
 103          , writer_styles  = def
 104          }
 105 instance Semigroup Writer where
 106         x <> y = Writer
 107          { writer_scripts = HS.union (writer_scripts x) (writer_scripts y)
 108          , writer_styles  = HS.union (writer_styles  x) (writer_styles  y)
 109          }
 110 instance Monoid Writer where
 111         mempty  = def
 112         mappend = (<>)
 113
 114 -- ** Type 'State'
 115 data State = State
 116  { state_section          :: !(TS.Trees BodyNode)
 117  , state_errors           :: !(Analyze.Errors Nat1)
 118  , state_ref              :: !(HM.HashMap Ident Nat1)
 119  , state_at               :: !(HM.HashMap Ident Nat1)
 120  , state_tag              :: !(HM.HashMap Ident Nat1)
 121  , state_irefs            :: !(TM.TreeMap Word Nat1)
 122  , state_indices          :: ![(Terms, Analyze.Index)]
 123  , state_notes            :: ![Seq [Para]]
 124  , state_note_num_ref     :: !Nat1
 125  , state_note_num_content :: !Nat1
 126  , state_judgments        :: ![Judgment]
 127  , state_opinions         :: !(HM.HashMap Judgment [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)])
 128  }deriving (Show)
 129 instance Default State where
 130         def = State
 131          { state_section          = def
 132          , state_errors           = def
 133          , state_ref              = def
 134          , state_at               = def
 135          , state_tag              = def
 136          , state_irefs            = def
 137          , state_indices          = def
 138          , state_notes            = def
 139          , state_note_num_ref     = def
 140          , state_note_num_content = def
 141          , state_judgments        = def
 142          , state_opinions         = def
 143          }
 144
 145 -- * Class 'Html5ify'
 146 class Html5ify a where
 147         html5ify :: a -> HTML5
 148 instance Html5ify H.Markup where
 149         html5ify = Compose . return
 150 instance Html5ify Char where
 151         html5ify = html5ify . H.toMarkup
 152 instance Html5ify Text where
 153         html5ify = html5ify . H.toMarkup
 154 instance Html5ify TL.Text where
 155         html5ify = html5ify . H.toMarkup
 156 instance Html5ify String where
 157         html5ify = html5ify . H.toMarkup
 158 instance Html5ify Ident where
 159         html5ify (Ident i) = html5ify i
 160 instance Html5ify Int where
 161         html5ify = html5ify . show
 162 instance Html5ify Name where
 163         html5ify (Name i) = html5ify i
 164 instance Html5ify Nat where
 165         html5ify (Nat n) = html5ify n
 166 instance Html5ify Nat1 where
 167         html5ify (Nat1 n) = html5ify n
 168 instance Html5ify a => Html5ify (Maybe a) where
 169         html5ify = foldMap html5ify
 170
 171 html5AttrClass :: [TL.Text] -> HTML5 -> HTML5
 172 html5AttrClass = \case
 173  [] -> id
 174  cls  ->
 175         Compose .
 176         (H.AddCustomAttribute "class"
 177          (H.String $ TL.unpack $ TL.unwords cls) <$>) .
 178         getCompose
 179
 180 html5AttrId :: Ident -> HTML5 -> HTML5
 181 html5AttrId (Ident id_) =
 182         Compose .
 183         (H.AddCustomAttribute "id"
 184          (H.String $ TL.unpack id_) <$>) .
 185         getCompose
 186
 187 html5CommonAttrs :: CommonAttrs -> HTML5 -> HTML5
 188 html5CommonAttrs CommonAttrs{..} =
 189         html5AttrClass attrs_classes .
 190         maybe id html5AttrId attrs_id
 191
 192 -- * Class 'L10n'
 193 class
 194  ( Plain.L10n msg lang
 195  , Plain.L10n TL.Text lang
 196  ) => L10n msg lang where
 197         l10n_Header_Address                   :: FullLocale lang -> msg
 198         l10n_Header_Date                      :: FullLocale lang -> msg
 199         l10n_Header_Version                   :: FullLocale lang -> msg
 200         l10n_Header_Origin                    :: FullLocale lang -> msg
 201         l10n_Header_Source                    :: FullLocale lang -> msg
 202         l10n_Errors_All                       :: FullLocale lang -> Nat -> msg
 203         l10n_Error_At_unknown                 :: FullLocale lang -> msg
 204         l10n_Error_At_ambiguous               :: FullLocale lang -> msg
 205         l10n_Error_Rref_unknown               :: FullLocale lang -> msg
 206         l10n_Error_Reference_ambiguous        :: FullLocale lang -> msg
 207         l10n_Error_Judgment_Judges_unknown    :: FullLocale lang -> msg
 208         l10n_Error_Judgment_Judge_unknown     :: FullLocale lang -> msg
 209         l10n_Error_Judgment_Judge_duplicated  :: FullLocale lang -> msg
 210         l10n_Error_Judgment_Grades_unknown    :: FullLocale lang -> msg
 211         l10n_Error_Judgment_Grades_duplicated :: FullLocale lang -> msg
 212         l10n_Error_Judgment_Grade_unknown     :: FullLocale lang -> msg
 213         l10n_Error_Judgment_Choice_duplicated :: FullLocale lang -> msg
 214 instance L10n HTML5 EN where
 215         l10n_Header_Address _l10n = "Address"
 216         l10n_Header_Date    _l10n = "Date"
 217         l10n_Header_Origin  _l10n = "Origin"
 218         l10n_Header_Source  _l10n = "Source"
 219         l10n_Header_Version _l10n = "Version"
 220         l10n_Errors_All _l10n n = "All errors ("<>html5ify n<>")"
 221         l10n_Error_At_unknown   _l10n = "Unknown anchor"
 222         l10n_Error_At_ambiguous _l10n = "Ambiguous anchor"
 223         l10n_Error_Rref_unknown        _l10n = "Unknown reference"
 224         l10n_Error_Reference_ambiguous _l10n = "Ambiguous reference"
 225         l10n_Error_Judgment_Judges_unknown    _l10n = "Unknown judges"
 226         l10n_Error_Judgment_Judge_unknown     _l10n = "Unknown judge"
 227         l10n_Error_Judgment_Judge_duplicated  _l10n = "Duplicated judge"
 228         l10n_Error_Judgment_Grades_unknown    _l10n = "Unknown grades"
 229         l10n_Error_Judgment_Grades_duplicated _l10n = "Duplicated grades"
 230         l10n_Error_Judgment_Grade_unknown     _l10n = "Unknown grade"
 231         l10n_Error_Judgment_Choice_duplicated _l10n = "Duplicated choice"
 232 instance L10n HTML5 FR where
 233         l10n_Header_Address _l10n = "Adresse"
 234         l10n_Header_Date    _l10n = "Date"
 235         l10n_Header_Origin  _l10n = "Origine"
 236         l10n_Header_Source  _l10n = "Source"
 237         l10n_Header_Version _l10n = "Version"
 238         l10n_Errors_All _l10n n = "Toutes les erreurs ("<>html5ify n<>")"
 239         l10n_Error_At_unknown   _l10n = "Ancre inconnue"
 240         l10n_Error_At_ambiguous _l10n = "Ancre ambiguë"
 241         l10n_Error_Rref_unknown        _l10n = "Référence inconnue"
 242         l10n_Error_Reference_ambiguous _l10n = "Référence ambiguë"
 243         l10n_Error_Judgment_Judges_unknown    _l10n = "Juges inconnu·es"
 244         l10n_Error_Judgment_Judge_unknown     _l10n = "Juge unconnu·e"
 245         l10n_Error_Judgment_Judge_duplicated  _l10n = "Juge en double"
 246         l10n_Error_Judgment_Grades_unknown    _l10n = "Mentions inconnues"
 247         l10n_Error_Judgment_Grades_duplicated _l10n = "Mentions en double"
 248         l10n_Error_Judgment_Grade_unknown     _l10n = "Mention inconnue"
 249         l10n_Error_Judgment_Choice_duplicated _l10n = "Choix en double"
 250
 251 instance Plain.L10n HTML5 EN where
 252         l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
 253         l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
 254         l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
 255         l10n_Quote msg _l10n = do
 256                 depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
 257                 let (o,c) :: (HTML5, HTML5) =
 258                         case unNat depth `mod` 3 of
 259                          0 -> ("“","”")
 260                          1 -> ("« "," »")
 261                          _ -> ("‟","„")
 262                 o
 263                 localComposeRWS (\ro -> ro
 264                  {reader_plainify = (reader_plainify ro)
 265                          {Plain.reader_quote = succNat depth}}) $
 266                         msg
 267                 c
 268 instance Plain.L10n HTML5 FR where
 269         l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
 270         l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
 271         l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
 272         l10n_Quote msg _l10n = do
 273                 depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
 274                 let (o,c) :: (HTML5, HTML5) =
 275                         case unNat depth `mod` 3 of
 276                          0 -> ("« "," »")
 277                          1 -> ("“","”")
 278                          _ -> ("‟","„")
 279                 o
 280                 localComposeRWS (\ro -> ro
 281                  {reader_plainify = (reader_plainify ro)
 282                          {Plain.reader_quote = succNat depth}}) $
 283                         msg
 284                 c