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
  37 -- * Type 'PathWord'
  38 type PathWord = TreeMap.Path Word
  39
  40 pathFromWords :: Words -> Maybe PathWord
  41 pathFromWords ws =
  42         case ws >>= unSpace of
  43          p:ps | not (TL.null p) -> Just (TreeMap.path p ps)
  44          _ -> Nothing
  45         where
  46         unSpace = \case
  47          Space  -> []
  48          Word w -> [w]
  49
  50 -- * Type 'Irefs'
  51 type Irefs = TreeMap Word [Anchor]
  52
  53 irefsOfTerms :: Terms -> Irefs
  54 irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
  55         where
  56         f [] = []
  57         f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
  58
  59 -- * Type 'Rrefs'
  60 type Rrefs = Map Ident [Anchor]
  61
  62 -- * Type 'Notes'
  63 type Notes = Map PosPath [Note]
  64 data Note
  65  =   Note
  66  {   note_number  :: Nat1
  67  ,   note_content :: [Para]
  68  } -- deriving (Eq,Show)
  69
  70 -- * Type 'State'
  71 data State
  72  =   State
  73  {   state_section :: Pos
  74  ,   state_irefs   :: Irefs
  75  ,   state_rrefs   :: Rrefs
  76  ,   state_notes   :: Notes
  77  ,   state_note    :: Nat1
  78  }
  79 instance Default State where
  80         def = State
  81          { state_section = def
  82          , state_irefs   = mempty
  83          , state_rrefs   = def
  84          , state_notes   = def
  85          , state_note    = def
  86          }
  87
  88 -- * Class 'Anchorify'
  89 class Anchorify a where
  90         anchorify :: a -> S.State State a
  91 instance Anchorify a => Anchorify (Maybe a) where
  92         anchorify = traverse anchorify
  93 instance Anchorify Body where
  94         anchorify = traverse anchorify
  95 instance Anchorify (Tree BodyNode) where
  96         anchorify = \case
  97          Tree n ts ->
  98                 case n of
  99                  BodySection{..} -> do
 100                         before@State{state_section} <- S.get
 101                         S.put before{state_section = pos}
 102                         t <- Tree <$> anchorify n <*> anchorify ts
 103                         after <- S.get
 104                         S.put after{state_section}
 105                         return t
 106                  BodyBlock{} -> tree0 <$> anchorify n
 107 instance Anchorify BodyNode where
 108         anchorify = \case
 109          BodySection{..} ->
 110                 BodySection pos attrs
 111                  <$> anchorify title
 112                  <*> pure aliases
 113                  <*> traverse anchorify judgments
 114          BodyBlock b -> BodyBlock <$> anchorify b
 115 instance Anchorify Block where
 116         anchorify = \case
 117          BlockPara p     -> BlockPara <$> anchorify p
 118          b@BlockBreak{}  -> return b
 119          b@BlockToC{}    -> return b
 120          b@BlockToF{}    -> return b
 121          b@BlockIndex{}  -> return b
 122          BlockAside{..} ->
 123                 BlockAside pos attrs
 124                  <$> traverse anchorify blocks
 125          BlockFigure{..} ->
 126                 BlockFigure pos type_ attrs
 127                  <$> anchorify mayTitle
 128                  <*> traverse anchorify paras
 129          BlockReferences{..} ->
 130                 BlockReferences pos attrs
 131                  <$> traverse anchorify refs
 132          BlockJudges{..} ->
 133                 BlockJudges pos attrs
 134                  <$> traverse anchorify jury
 135          BlockGrades{..} ->
 136                 BlockGrades pos attrs
 137                  <$> traverse anchorify scale
 138 instance Anchorify Para where
 139         anchorify = \case
 140          ParaItem{..}  -> ParaItem <$> anchorify item
 141          ParaItems{..} -> ParaItems pos attrs <$> traverse anchorify items
 142 instance Anchorify ParaItem where
 143         anchorify = \case
 144          ParaPlain plain -> ParaPlain       <$> anchorify plain
 145          ParaOL items    -> ParaOL          <$> traverse anchorify items
 146          ParaUL items    -> ParaUL          <$> traverse (traverse anchorify) items
 147          ParaQuote{..}   -> ParaQuote type_ <$> traverse anchorify paras
 148          p@ParaArtwork{} -> return p
 149          p@ParaComment{} -> return p
 150          ParaJudgment j  -> ParaJudgment <$> anchorify j
 151 instance Anchorify ListItem where
 152         anchorify ListItem{..} = ListItem name <$> traverse anchorify paras
 153 instance Anchorify Judgment where
 154         anchorify Judgment{..} =
 155                 Judgment judges grades importance
 156                  <$> anchorify question
 157                  <*> traverse anchorify choices
 158 instance Anchorify Plain where
 159         anchorify p = do
 160                 State{..} <- S.get
 161                 indexed <-
 162                         if null state_irefs
 163                         then return p
 164                         else traverse anchorify p
 165                 traverse (traverse collect) indexed
 166                 where
 167                 -- TODO: maybe move to Anchorify (Tree PlainNode)
 168                 collect :: PlainNode -> S.State State PlainNode
 169                 collect = \case
 170                  PlainNote{..} -> do
 171                         State{..} <- S.get
 172                         let notes = Map.findWithDefault [] (pos_Ancestors state_section) state_notes
 173                         S.modify $ \s -> s
 174                          { state_notes = Map.insert (pos_Ancestors state_section) (Note state_note note:notes) state_notes
 175                          , state_note  = succNat1 state_note }
 176                         return PlainNote{number=Just state_note, note}
 177                  PlainRref{..} -> do
 178                         State{..} <- S.get
 179                         let anchs = Map.findWithDefault [] to state_rrefs
 180                         let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 181                         let anch = Anchor{count, section=state_section}
 182                         S.modify $ \s -> s{state_rrefs=
 183                                 Map.insert to (anch:anchs) state_rrefs}
 184                         return PlainRref{anchor=Just anch, to}
 185                  n -> return n
 186 instance Anchorify (Tree PlainNode) where
 187         anchorify (Tree n ts) =
 188                 case n of
 189                  PlainIref{term} | Just words <- pathFromWords term -> do
 190                         State{state_irefs, state_section} <- S.get
 191                         case TreeMap.lookup words state_irefs of
 192                          Strict.Nothing ->
 193                                 Tree n <$> traverse anchorify ts
 194                          Strict.Just anchs -> do
 195                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 196                                 let anch = Anchor{count, section=state_section}
 197                                 S.modify $ \s -> s{state_irefs=
 198                                         TreeMap.insert const words (anch:anchs) state_irefs}
 199                                 Tree PlainIref{term, anchor=Just anch}
 200                                  <$> traverse anchorify ts
 201                  PlainText txt -> do
 202                         State{..} <- S.get
 203                         let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
 204                         S.modify $ \s -> s{state_irefs=irefs}
 205                         return $ Tree PlainGroup para
 206                  _ -> Tree n <$> traverse anchorify ts
 207 instance Anchorify Title where
 208         anchorify (Title p) = Title <$> anchorify p
 209 instance Anchorify Reference where
 210         anchorify = return
 211 instance Anchorify Choice where
 212         anchorify Choice{..} =
 213                 Choice
 214                  <$> anchorify title
 215                  <*> traverse anchorify opinions
 216 instance Anchorify Opinion where
 217         anchorify Opinion{..} =
 218                 Opinion judge grade importance
 219                  <$> anchorify comment
 220 instance Anchorify Grade where
 221         anchorify Grade{..} =
 222                 Grade pos name color isDefault
 223                  <$> anchorify title
 224 instance Anchorify Judge where
 225         anchorify Judge{..} =
 226                 Judge name
 227                  <$> anchorify title
 228                  <*> pure defaultGrades
 229
 230 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
 231 indexifyWords section = go mempty
 232         where
 233         go :: Plain -> Irefs -> Words -> (Irefs, Plain)
 234         go acc irefs inp =
 235                 case inp of
 236                  [] -> (irefs, acc)
 237                  Space : next ->
 238                         go (acc |> tree0 (PlainText " ")) irefs next
 239                  Word w : next ->
 240                         case goWords irefs [] inp of
 241                          Nothing -> go (acc |> tree0 (PlainText w)) irefs next
 242                          Just (anch, ls, ns, rs) ->
 243                                 let term = List.reverse ls in
 244                                 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
 245                                 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
 246         goWords ::
 247          Irefs ->
 248          Words -> Words ->
 249          Maybe (Anchor, Words, Words, Irefs)
 250         goWords m@(TreeMap irefsByWord) prev inp =
 251                 case inp of
 252                  [] -> Nothing
 253                  curr@Space : next -> goWords m (curr:prev) next
 254                  curr@(Word w) : next ->
 255                         case Map.lookup w irefsByWord of
 256                          Nothing -> Nothing
 257                          Just nod@TreeMap.Node{..} ->
 258                                 let prev' = curr:prev in
 259                                 case node_value of
 260                                  Strict.Nothing
 261                                   | null node_descendants -> Nothing
 262                                   | otherwise ->
 263                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
 264                                                 (anch, ls, ns, TreeMap $
 265                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 266                                  Strict.Just anchs ->
 267                                         case goWords node_descendants prev' next of
 268                                          Nothing ->
 269                                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
 270                                                 let anch  = Anchor{count, section} in
 271                                                 Just (anch, prev', next, TreeMap $
 272                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
 273                                          Just (anch, ls, ns, rs) ->
 274                                                 Just (anch, ls, ns, TreeMap $
 275                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 276
 277 wordify :: TL.Text -> Words
 278 wordify = List.reverse . go []
 279         where
 280         go :: Words -> TL.Text -> Words
 281         go acc t =
 282                 case TL.span Char.isAlphaNum t of
 283                  ("",_) ->
 284                         case TL.span Char.isSpace t of
 285                          ("",_) ->
 286                                 case TL.uncons t of
 287                                  Nothing -> acc
 288                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
 289                          (_s,r) -> go (Space : acc) r
 290                  (w,r) -> go (Word w : acc) r
 291
 292 plainifyWord :: WordOrSpace -> TL.Text
 293 plainifyWord = \case
 294  Word w -> w
 295  Space  -> " "
 296
 297 plainifyWords :: Words -> TL.Text
 298 plainifyWords = TL.concat . (plainifyWord <$>)
 299
 300 termsByChar :: Terms -> Map Char Terms
 301 termsByChar =
 302         foldr (\aliases acc ->
 303                 case aliases of
 304                  (Word w:_):_ | not (TL.null w) ->
 305                         Map.insertWith (<>)
 306                          (Char.toUpper $ TL.index w 0)
 307                          [aliases] acc
 308                  _ -> acc
 309                 ) Map.empty