Hdoc/DTC/Anchor.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hdoc.DTC.Anchor where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Category
  10 import Control.Monad (Monad(..))
  11 import Data.Bool
  12 import Data.Char (Char)
  13 import Data.Default.Class (Default(..))
  14 import Data.Foldable (Foldable(..), concat)
  15 import Data.Function (($), const)
  16 import Data.Functor ((<$>))
  17 import Data.Map.Strict (Map)
  18 import Data.Maybe (Maybe(..), maybe)
  19 import Data.Monoid (Monoid(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.Sequence ((|>))
  22 import Data.Traversable (Traversable(..))
  23 import Data.TreeMap.Strict (TreeMap(..))
  24 import Data.TreeSeq.Strict (Tree(..), tree0)
  25 import qualified Control.Monad.Trans.State as S
  26 import qualified Data.Char as Char
  27 import qualified Data.List as List
  28 import qualified Data.Map.Strict as Map
  29 import qualified Data.Sequence as Seq
  30 import qualified Data.Strict.Maybe as Strict
  31 import qualified Data.Text.Lazy as TL
  32 import qualified Data.TreeMap.Strict as TreeMap
  33 -- import qualified Data.TreeSeq.Strict as TreeSeq
  34
  35 import Hdoc.DTC.Document
  36 import Hdoc.DTC.Index
  37
  38 -- * Type 'Rrefs'
  39 type Rrefs = Map Ident [Anchor]
  40
  41 -- * Type 'Notes'
  42 -- | 'Note' by 'BodySection'.
  43 type Notes = Map PosPath [Note]
  44
  45 -- ** Type 'Note'
  46 data Note = Note
  47  { note_number  :: Nat1
  48  , note_content :: [Para]
  49  } -- deriving (Eq,Show)
  50
  51 -- * Type 'State'
  52 data State = State
  53  { state_section :: Pos
  54  , state_irefs   :: Irefs
  55  , state_rrefs   :: Rrefs
  56  , state_notes   :: Notes
  57  , state_note    :: Nat1
  58  }
  59 instance Default State where
  60         def = State
  61          { state_section = def
  62          , state_irefs   = mempty
  63          , state_rrefs   = def
  64          , state_notes   = def
  65          , state_note    = def
  66          }
  67
  68 -- * Class 'Anchorify'
  69 class Anchorify a where
  70         anchorify :: a -> S.State State a
  71 instance Anchorify a => Anchorify (Maybe a) where
  72         anchorify = traverse anchorify
  73 instance Anchorify Body where
  74         anchorify = traverse anchorify
  75 instance Anchorify (Tree BodyNode) where
  76         anchorify = \case
  77          Tree n ts ->
  78                 case n of
  79                  BodySection{..} -> do
  80                         before@State{state_section} <- S.get
  81                         S.put before{state_section = pos}
  82                         t <- Tree <$> anchorify n <*> anchorify ts
  83                         after <- S.get
  84                         S.put after{state_section}
  85                         return t
  86                  BodyBlock{} -> tree0 <$> anchorify n
  87 instance Anchorify BodyNode where
  88         anchorify = \case
  89          BodySection{..} ->
  90                 BodySection pos attrs
  91                  <$> anchorify title
  92                  <*> pure aliases
  93                  <*> traverse anchorify judgments
  94          BodyBlock b -> BodyBlock <$> anchorify b
  95 instance Anchorify Block where
  96         anchorify = \case
  97          BlockPara p     -> BlockPara <$> anchorify p
  98          b@BlockBreak{}  -> return b
  99          b@BlockToC{}    -> return b
 100          b@BlockToF{}    -> return b
 101          b@BlockIndex{}  -> return b
 102          BlockAside{..} ->
 103                 BlockAside pos attrs
 104                  <$> traverse anchorify blocks
 105          BlockFigure{..} ->
 106                 BlockFigure pos type_ attrs
 107                  <$> anchorify mayTitle
 108                  <*> traverse anchorify paras
 109          BlockReferences{..} ->
 110                 BlockReferences pos attrs
 111                  <$> traverse anchorify refs
 112          BlockJudges{..} ->
 113                 BlockJudges pos attrs
 114                  <$> traverse anchorify jury
 115          BlockGrades{..} ->
 116                 BlockGrades pos attrs
 117                  <$> traverse anchorify scale
 118 instance Anchorify Para where
 119         anchorify = \case
 120          ParaItem{..}  -> ParaItem <$> anchorify item
 121          ParaItems{..} -> ParaItems pos attrs <$> traverse anchorify items
 122 instance Anchorify ParaItem where
 123         anchorify = \case
 124          ParaPlain plain -> ParaPlain       <$> anchorify plain
 125          ParaOL items    -> ParaOL          <$> traverse anchorify items
 126          ParaUL items    -> ParaUL          <$> traverse (traverse anchorify) items
 127          ParaQuote{..}   -> ParaQuote type_ <$> traverse anchorify paras
 128          p@ParaArtwork{} -> return p
 129          p@ParaComment{} -> return p
 130          ParaJudgment j  -> ParaJudgment <$> anchorify j
 131 instance Anchorify ListItem where
 132         anchorify ListItem{..} = ListItem name <$> traverse anchorify paras
 133 instance Anchorify Judgment where
 134         anchorify Judgment{..} =
 135                 Judgment judges grades importance
 136                  <$> anchorify question
 137                  <*> traverse anchorify choices
 138 instance Anchorify Plain where
 139         anchorify = traverse anchorify
 140 instance Anchorify (Tree PlainNode) where
 141         anchorify (Tree n ts) = do
 142                 State{..} <- S.get
 143                 case n of
 144                  PlainIref{term}
 145                   | not $ null state_irefs
 146                   , Just words <- pathFromWords term
 147                   , Strict.Just anchs <- TreeMap.lookup words state_irefs -> do
 148                         let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 149                         let anch = Anchor{count, section=state_section}
 150                         S.modify' $ \s -> s
 151                          { state_irefs = TreeMap.insert const words (anch:anchs) state_irefs }
 152                         Tree PlainIref{term, anchor=Just anch}
 153                          <$> traverse anchorify ts
 154                  PlainText txt
 155                   | not $ null state_irefs -> do
 156                         let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
 157                         S.modify' $ \s -> s
 158                          { state_irefs = irefs }
 159                         return $ Tree PlainGroup para
 160                  PlainNote{..} -> do
 161                         let notes = Map.findWithDefault [] (pos_Ancestors state_section) state_notes
 162                         S.modify' $ \s -> s
 163                          { state_notes = Map.insert (pos_Ancestors state_section) (Note state_note note:notes) state_notes
 164                          , state_note  = succNat1 state_note }
 165                         Tree PlainNote{number=Just state_note, note}
 166                          <$> traverse anchorify ts -- NOTE: normally ts is empty anyway
 167                  PlainRref{..} -> do
 168                         let anchs = Map.findWithDefault [] to state_rrefs
 169                         let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 170                         let anch = Anchor{count, section=state_section}
 171                         S.modify' $ \s -> s
 172                          { state_rrefs = Map.insert to (anch:anchs) state_rrefs }
 173                         Tree PlainRref{anchor=Just anch, to}
 174                          <$> traverse anchorify ts
 175                  _ -> Tree n <$> traverse anchorify ts
 176 instance Anchorify Title where
 177         anchorify (Title p) = Title <$> anchorify p
 178 instance Anchorify Reference where
 179         anchorify = return
 180 instance Anchorify Choice where
 181         anchorify Choice{..} =
 182                 Choice
 183                  <$> anchorify title
 184                  <*> traverse anchorify opinions
 185 instance Anchorify Opinion where
 186         anchorify Opinion{..} =
 187                 Opinion judge grade importance
 188                  <$> anchorify comment
 189 instance Anchorify Grade where
 190         anchorify Grade{..} =
 191                 Grade pos name color isDefault
 192                  <$> anchorify title
 193 instance Anchorify Judge where
 194         anchorify Judge{..} =
 195                 Judge name
 196                  <$> anchorify title
 197                  <*> pure defaultGrades