]> Git — Sourcephile - doclang.git/blob - src/Textphile/DTC/Write/HTML5/Base.hs
stack: add stack.yaml.lock
[doclang.git] / src / Textphile / 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 Textphile.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 Majority.Judgment as MJ
38 import qualified Text.Blaze.Html5 as H
39 import qualified Text.Blaze.Internal as H
40
41 import Control.Monad.Utils
42 import Textphile.Utils ()
43 import Textphile.DTC.Document as DTC
44 import Textphile.DTC.Write.XML ()
45 import qualified Textphile.DTC.Analyze.Check as Analyze
46 import qualified Textphile.DTC.Analyze.Collect as Analyze
47 -- import qualified Textphile.DTC.Analyze.Index as Analyze
48 import qualified Textphile.DTC.Write.Plain as Plain
49 import qualified Text.Blaze.Internal as B
50
51 -- * Type 'HTML5'
52 type HTML5 = ComposeRWS Reader Writer 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/textphile"
75 }
76
77 -- ** Type 'Reader'
78 data Reader = Reader
79 { reader_l10n :: Loqualization (L10n HTML5)
80 , reader_plainify :: Plain.Reader
81 , reader_italic :: Bool
82 , reader_all :: Analyze.All
83 , reader_body :: Body
84 , reader_section :: [Section]
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_body = def
93 , reader_section = def
94 }
95
96 -- ** Type 'Writer'
97 data Writer = Writer
98 { writer_scripts :: HS.HashSet FilePath
99 , writer_styles :: HS.HashSet (Either FilePath TL.Text)
100 }
101 instance Default Writer where
102 def = Writer
103 { writer_scripts = def
104 , writer_styles = def
105 }
106 instance Semigroup Writer where
107 x <> y = Writer
108 { writer_scripts = HS.union (writer_scripts x) (writer_scripts y)
109 , writer_styles = HS.union (writer_styles x) (writer_styles y)
110 }
111 instance Monoid Writer where
112 mempty = def
113 mappend = (<>)
114
115 -- ** Type 'State'
116 data State = State
117 { state_errors :: !(Analyze.Errors Nat1)
118 , state_ref :: !(HM.HashMap Ident Nat1)
119 , state_pageRef :: !(HM.HashMap PathPage Nat1)
120 , state_at :: !(HM.HashMap Ident Nat1)
121 , state_tag :: !(HM.HashMap Ident Nat1)
122 , state_irefs :: !(TM.TreeMap Word Nat1)
123 , state_indices :: ![(Terms, Index)]
124 , state_notes :: ![Seq [Para]]
125 , state_note_num_ref :: !Nat1
126 , state_note_num_content :: !Nat1
127 , state_judgments :: !(HM.HashMap JudgmentKey [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)])
128 } deriving (Show)
129 instance Default State where
130 def = State
131 { state_errors = def
132 , state_ref = def
133 , state_pageRef = 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 }
143
144 -- * Class 'Html5ify'
145 class Html5ify a where
146 html5ify :: a -> HTML5
147 instance Html5ify H.Markup where
148 html5ify = Compose . return
149 instance Html5ify Char where
150 html5ify = html5ify . H.toMarkup
151 instance Html5ify Text where
152 html5ify = html5ify . H.toMarkup
153 instance Html5ify TL.Text where
154 html5ify = html5ify . H.toMarkup
155 instance Html5ify String where
156 html5ify = html5ify . H.toMarkup
157 instance Html5ify Ident where
158 html5ify (Ident i) = html5ify i
159 instance Html5ify Int where
160 html5ify = html5ify . show
161 instance Html5ify Name where
162 html5ify (Name i) = html5ify i
163 instance Html5ify Nat where
164 html5ify (Nat n) = html5ify n
165 instance Html5ify Nat1 where
166 html5ify (Nat1 n) = html5ify n
167 instance Html5ify a => Html5ify (Maybe a) where
168 html5ify = foldMap html5ify
169
170 html5AttrClass :: [TL.Text] -> HTML5 -> HTML5
171 html5AttrClass = \case
172 [] -> id
173 cls ->
174 Compose .
175 (H.AddCustomAttribute "class"
176 (H.String $ TL.unpack $ TL.unwords cls) <$>) .
177 getCompose
178
179 html5AttrId :: Ident -> HTML5 -> HTML5
180 html5AttrId (Ident id_) =
181 Compose .
182 (H.AddCustomAttribute "id"
183 (H.String $ TL.unpack id_) <$>) .
184 getCompose
185
186 html5CommonAttrs :: CommonAttrs -> HTML5 -> HTML5
187 html5CommonAttrs CommonAttrs{..} =
188 html5AttrClass attrs_classes .
189 maybe id html5AttrId attrs_id
190
191 -- * Class 'L10n'
192 class
193 ( Plain.L10n msg lang
194 , Plain.L10n TL.Text lang
195 ) => L10n msg lang where
196 l10n_Header_Address :: FullLocale lang -> msg
197 l10n_Header_Date :: FullLocale lang -> msg
198 l10n_Header_Version :: FullLocale lang -> msg
199 l10n_Header_Origin :: FullLocale lang -> msg
200 l10n_Header_Source :: FullLocale lang -> msg
201 l10n_Errors_All :: FullLocale lang -> Nat -> msg
202 l10n_Error_At_unknown :: FullLocale lang -> msg
203 l10n_Error_At_ambiguous :: FullLocale lang -> msg
204 l10n_Error_Rref_unknown :: FullLocale lang -> msg
205 l10n_Error_Reference_ambiguous :: FullLocale lang -> msg
206 l10n_Error_Judgment_Judges_unknown :: FullLocale lang -> msg
207 l10n_Error_Judgment_Judge_unknown :: FullLocale lang -> msg
208 l10n_Error_Judgment_Judge_duplicated :: FullLocale lang -> msg
209 l10n_Error_Judgment_Grades_unknown :: FullLocale lang -> msg
210 l10n_Error_Judgment_Grades_duplicated :: FullLocale lang -> msg
211 l10n_Error_Judgment_Grade_unknown :: FullLocale lang -> msg
212 l10n_Error_Judgment_Choice_duplicated :: FullLocale lang -> msg
213 instance L10n HTML5 EN where
214 l10n_Header_Address _l10n = "Address"
215 l10n_Header_Date _l10n = "Date"
216 l10n_Header_Origin _l10n = "Origin"
217 l10n_Header_Source _l10n = "Source"
218 l10n_Header_Version _l10n = "Version"
219 l10n_Errors_All _l10n n = "All errors ("<>html5ify n<>")"
220 l10n_Error_At_unknown _l10n = "Unknown anchor"
221 l10n_Error_At_ambiguous _l10n = "Ambiguous anchor"
222 l10n_Error_Rref_unknown _l10n = "Unknown reference"
223 l10n_Error_Reference_ambiguous _l10n = "Ambiguous reference"
224 l10n_Error_Judgment_Judges_unknown _l10n = "Unknown judges"
225 l10n_Error_Judgment_Judge_unknown _l10n = "Unknown judge"
226 l10n_Error_Judgment_Judge_duplicated _l10n = "Duplicated judge"
227 l10n_Error_Judgment_Grades_unknown _l10n = "Unknown grades"
228 l10n_Error_Judgment_Grades_duplicated _l10n = "Duplicated grades"
229 l10n_Error_Judgment_Grade_unknown _l10n = "Unknown grade"
230 l10n_Error_Judgment_Choice_duplicated _l10n = "Duplicated choice"
231 instance L10n HTML5 FR where
232 l10n_Header_Address _l10n = "Adresse"
233 l10n_Header_Date _l10n = "Date"
234 l10n_Header_Origin _l10n = "Origine"
235 l10n_Header_Source _l10n = "Source"
236 l10n_Header_Version _l10n = "Version"
237 l10n_Errors_All _l10n n = "Toutes les erreurs ("<>html5ify n<>")"
238 l10n_Error_At_unknown _l10n = "Ancre inconnue"
239 l10n_Error_At_ambiguous _l10n = "Ancre ambiguë"
240 l10n_Error_Rref_unknown _l10n = "Référence inconnue"
241 l10n_Error_Reference_ambiguous _l10n = "Référence ambiguë"
242 l10n_Error_Judgment_Judges_unknown _l10n = "Juges inconnu·es"
243 l10n_Error_Judgment_Judge_unknown _l10n = "Juge unconnu·e"
244 l10n_Error_Judgment_Judge_duplicated _l10n = "Juge en double"
245 l10n_Error_Judgment_Grades_unknown _l10n = "Mentions inconnues"
246 l10n_Error_Judgment_Grades_duplicated _l10n = "Mentions en double"
247 l10n_Error_Judgment_Grade_unknown _l10n = "Mention inconnue"
248 l10n_Error_Judgment_Choice_duplicated _l10n = "Choix en double"
249
250 instance Plain.L10n HTML5 EN where
251 l10n_Colon l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
252 l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
253 l10n_Date date l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
254 l10n_Quote msg _l10n = do
255 depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
256 let (o,c) :: (HTML5, HTML5) =
257 case unNat depth `mod` 3 of
258 0 -> ("“","”")
259 1 -> ("« "," »")
260 _ -> ("‟","„")
261 o
262 localComposeRWS (\ro -> ro
263 {reader_plainify = (reader_plainify ro)
264 {Plain.reader_quote = succNat depth}}) $
265 msg
266 c
267 instance Plain.L10n HTML5 FR where
268 l10n_Colon l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
269 l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
270 l10n_Date date l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
271 l10n_Quote msg _l10n = do
272 depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
273 let (o,c) :: (HTML5, HTML5) =
274 case unNat depth `mod` 3 of
275 0 -> ("« "," »")
276 1 -> ("“","”")
277 _ -> ("‟","„")
278 o
279 localComposeRWS (\ro -> ro
280 {reader_plainify = (reader_plainify ro)
281 {Plain.reader_quote = succNat depth}}) $
282 msg
283 c