Hdoc/DTC/Write/HTML5/Error.hs

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