src/Textphile/DTC/Write/HTML5/Error.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Textphile.DTC.Write.HTML5.Error where
   8
   9 import Control.Applicative (Applicative(..))
  10 import Control.Monad (forM_, mapM_)
  11 import Data.Default.Class (Default(..))
  12 import Data.Either (Either(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>))
  16 import Data.Int (Int)
  17 import Data.Locale hiding (Index)
  18 import Data.Map.Strict (Map)
  19 import Data.Maybe (Maybe(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Sequence (Seq(..))
  23 import Data.TreeSeq.Strict (tree0)
  24 import Data.Tuple (fst, snd)
  25 import Text.Blaze ((!))
  26 import Text.Show (Show(..))
  27 import qualified Control.Monad.Trans.RWS.Strict as RWS
  28 import qualified Data.HashMap.Strict as HM
  29 import qualified Data.HashSet as HS
  30 import qualified Data.List as List
  31 import qualified Data.Map.Strict as Map
  32 import qualified Data.Text.Lazy as TL
  33 import qualified Text.Blaze.Html5 as H
  34 import qualified Text.Blaze.Html5.Attributes  as HA
  35
  36 import Control.Monad.Utils
  37 import Textphile.DTC.Document as DTC
  38 import Textphile.DTC.Write.HTML5.Base
  39 import Textphile.DTC.Write.HTML5.Ident
  40 import Textphile.DTC.Write.XML ()
  41 import Text.Blaze.Utils
  42 import qualified Textphile.DTC.Analyze.Check as Analyze
  43 import qualified Textphile.DTC.Analyze.Collect as Analyze
  44 import qualified Textphile.DTC.Write.Plain as Plain
  45 import qualified Textphile.TCT.Cell as TCT
  46 import qualified Textphile.XML as XML
  47
  48 instance (Html5ify Plain, Html5ify TCT.Location) => Html5ify (Analyze.Errors (Seq Location)) where
  49         html5ify Analyze.Errors{..} = do
  50                 Reader
  51                  { reader_all  = Analyze.All{..}
  52                  , reader_l10n = Loqualization (l10n::FullLocale lang)
  53                  , ..
  54                  } <- composeLift RWS.ask
  55                 let errors :: [ ( Int{-errKind-}
  56                                 , HTML5{-errKindDescr-}
  57                                 , [(Plain{-errTypeKey-}, [(TCT.Location{-errPos-}, Ident{-errId-})])]
  58                                 ) ] =
  59                         List.zipWith
  60                          (\errKind (errKindDescr, errByPosByKey) ->
  61                                 (errKind, errKindDescr l10n, errByPosByKey))
  62                          [1::Int ..]
  63                          [ (l10n_Error_At_unknown                , errorAt "-unknown"   errors_at_unknown)
  64                          , (l10n_Error_At_ambiguous              , errorAt "-ambiguous" errors_at_ambiguous)
  65                          , (l10n_Error_Rref_unknown              , errorReference "-unknown"   errors_ref_unknown)
  66                          , (l10n_Error_Reference_ambiguous       , errorReference "-ambiguous" errors_reference_ambiguous)
  67                          , (l10n_Error_Judgment_Judges_unknown   , errorIdent errors_judgment_judges_unknown)
  68                          , (l10n_Error_Judgment_Grades_unknown   , errorIdent errors_judgment_grades_unknown)
  69                          , (l10n_Error_Judgment_Grades_duplicated, errorIdent errors_judgment_grades_duplicated)
  70                          , (l10n_Error_Judgment_Judge_unknown    , errorName  errors_judgment_judge_unknown)
  71                          , (l10n_Error_Judgment_Judge_duplicated , errorName  errors_judgment_judge_duplicated)
  72                          , (l10n_Error_Judgment_Choice_duplicated, errorTitle errors_judgment_choice_duplicated)
  73                          , (l10n_Error_Judgment_Grade_unknown    , errorName  errors_judgment_grade_unknown)
  74                          ]
  75                 let numErrors = Nat $ sum $ (<$> errors) $ \(_typ, _descr, errByPosByKey) ->
  76                         sum $ length . snd <$> errByPosByKey
  77                 when (numErrors > Nat 0) $ do
  78                         composeLift $ RWS.tell def
  79                          { writer_styles  = HS.fromList
  80                                  [ Left "dtc-errors.css"
  81                                  , Right $
  82                                         -- NOTE: Implement a CSS-powered show/hide logic, using :target
  83                                         "\n@media screen {" <>
  84                                         "\n\t.error-filter:target .errors-list > li {display:none;}" <>
  85                                         (`foldMap` errors) (\(num, _description, errs) ->
  86                                                 if null errs then "" else
  87                                                         let err = "error-type"<>TL.pack (show num)<>"\\." in
  88                                                         "\n\t.error-filter#"<>err<>":target .errors-list > li."<>err
  89                                                          <>" {display:list-item}" <>
  90                                                         "\n\t.error-filter#"<>err<>":target .errors-nav > ul > li."<>err
  91                                                          <>" {list-style-type:disc;}"
  92                                          ) <>
  93                                         "\n}"
  94                                  ]
  95                          }
  96                         filterIds errors $ H.div ! HA.class_ "document-errors" ! HA.id "document-errors." $$ do
  97                                 H.nav ! HA.class_ "errors-nav" $$ do
  98                                         H.p ! HA.class_ "errors-all" $$
  99                                                 H.a ! HA.href (refIdent "document-errors.") $$ do
 100                                                         l10n_Errors_All l10n numErrors :: HTML5
 101                                         H.ul $$
 102                                                 forM_ errors $
 103                                                  \(errKind, errKindDescr, errs) -> do
 104                                                         unless (null errs) $ do
 105                                                                 H.li ! HA.class_ (attrify $ errorType errKind) $$ do
 106                                                                         H.a ! HA.href (refIdent $ errorType errKind) $$ do
 107                                                                                 errKindDescr
 108                                                                                 " ("::HTML5
 109                                                                                 html5ify $ sum $ length . snd <$> errs
 110                                                                                 ")"
 111                                 H.ol ! HA.class_ "errors-list" $$ do
 112                                         let errByPosByKind :: Map TCT.Location{-errPos-}
 113                                                                   (Seq ( Int{-errKind-}
 114                                                                        , HTML5{-errKindDescr-}
 115                                                                        , Plain{-errKey-}
 116                                                                        , [(TCT.Location{-errPos-}, Ident{-errId-})] )) =
 117                                                 Map.unionsWith (<>) $ (<$> errors) $ \(errKind, errKindDescr, errByKey) ->
 118                                                         Map.unionsWith (<>) $ (<$> errByKey) $ \(errKey, errByPos) ->
 119                                                                 Map.singleton (fst $ List.head errByPos) $
 120                                                                  -- NOTE: sort using the first position of this errKind with this errKey.
 121                                                                         pure (errKind, errKindDescr, errKey, errByPos)
 122                                         forM_ errByPosByKind $
 123                                                 mapM_ $ \(errKind, errKindDescr, errKey, errByPos) -> do
 124                                                         H.li ! HA.class_ (attrify $ errorType errKind) $$ do
 125                                                                 H.span ! HA.class_ "error-message" $$ do
 126                                                                         H.span ! HA.class_ "error-kind" $$ do
 127                                                                                 errKindDescr
 128                                                                                 Plain.l10n_Colon l10n :: HTML5
 129                                                                         html5ify errKey
 130                                                                 H.ol ! HA.class_ "error-location" $$
 131                                                                         forM_ errByPos $ \(errPos, errId) ->
 132                                                                                 H.li $$
 133                                                                                         H.a ! HA.href (refIdent errId) $$
 134                                                                                                 html5ify errPos
 135                 where
 136                 errorType num = identify $ "error-type"<>show num<>"."
 137                 -- | Nest error id= to enable showing/hidding errors using :target pseudo-class.
 138                 filterIds [] h = h
 139                 filterIds ((num, _description, errs):es) h =
 140                         if null errs
 141                          then filterIds es h
 142                          else do
 143                                 H.div ! HA.class_ "error-filter"
 144                                       ! HA.id (attrify $ errorType num) $$
 145                                         filterIds es h
 146                 errorAt :: Ident -> HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
 147                 errorAt suffix errs =
 148                         (<$> HM.toList errs) $ \(ref, errPositions) ->
 149                                 ( pure $ tree0 $ PlainText $ unIdent ref
 150                                 , List.zipWith
 151                                  (\num (locTCT, _posXML) -> (locTCT, identifyAt suffix ref (Just $ Nat1 num)))
 152                                  [1::Int ..] (toList errPositions)
 153                                 )
 154                 errorReference :: Ident -> HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
 155                 errorReference suffix errs =
 156                         (<$> HM.toList errs) $ \(id, errPositions) ->
 157                                 ( pure $ tree0 $ PlainText $ unIdent id
 158                                 , List.zipWith
 159                                  (\num (locTCT, _posXML) -> (locTCT, identifyReference suffix id (Just $ Nat1 num)))
 160                                  [1::Int ..] (toList errPositions)
 161                                 )
 162                 errorIdent :: HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
 163                 errorIdent errs =
 164                         (<$> HM.toList errs) $ \(id, errPositions) ->
 165                                 ( pure $ tree0 $ PlainText $ unIdent id
 166                                 , (\(locTCT, posXML) ->
 167                                         (locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
 168                                  <$> toList errPositions
 169                                 )
 170                 errorName :: HM.HashMap Name (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
 171                 errorName errs =
 172                         (<$> HM.toList errs) $ \(name, errPositions) ->
 173                                 ( pure $ tree0 $ PlainText $ unName name
 174                                 , (\(locTCT, posXML) ->
 175                                         (locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
 176                                  <$> toList errPositions
 177                                 )
 178                 errorTitle :: HM.HashMap Title (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
 179                 errorTitle errs =
 180                         (<$> HM.toList errs) $ \(title, errPositions) ->
 181                                 ( unTitle title
 182                                 , (\(locTCT, posXML) ->
 183                                         (locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
 184                                  <$> toList errPositions
 185                                 )