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