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
  94 instance Anchorify Body where
  95         anchorify = traverse anchorify
  96 instance Anchorify (Tree BodyNode) where
  97         anchorify = \case
  98          Tree n ts ->
  99                 case n of
 100                  BodySection{..} -> do
 101                         before@State{state_section} <- S.get
 102                         S.put before{state_section = pos}
 103                         t <- Tree <$> anchorify n <*> anchorify ts
 104                         after <- S.get
 105                         S.put after{state_section}
 106                         return t
 107                  BodyBlock{} -> tree0 <$> anchorify n
 108 instance Anchorify BodyNode where
 109         anchorify = \case
 110          BodySection{..} ->
 111                 BodySection pos attrs
 112                  <$> anchorify title
 113                  <*> pure aliases
 114          BodyBlock b -> BodyBlock <$> anchorify b
 115
 116 instance Anchorify Block where
 117         anchorify = \case
 118          BlockPara p -> BlockPara <$> anchorify p
 119          b@BlockBreak{}   -> return b
 120          b@BlockToC{}     -> return b
 121          b@BlockToF{}     -> return b
 122          b@BlockIndex{}   -> return b
 123          BlockFigure{..} ->
 124                 BlockFigure pos attrs type_
 125                  <$> anchorify mayTitle
 126                  <*> anchorify paras
 127          BlockReferences{..} ->
 128                 BlockReferences pos attrs
 129                  <$> anchorify refs
 130 instance Anchorify [Block] where
 131         anchorify = traverse anchorify
 132 instance Anchorify [[Block]] where
 133         anchorify = traverse anchorify
 134
 135 instance Anchorify Para where
 136         anchorify = \case
 137          ParaItem{..}  -> ParaItem <$> anchorify item
 138          ParaItems{..} -> ParaItems pos attrs <$> anchorify items
 139 instance Anchorify ParaItem where
 140         anchorify = \case
 141          ParaPlain plain -> ParaPlain       <$> anchorify plain
 142          ParaOL items    -> ParaOL          <$> anchorify items
 143          ParaUL items    -> ParaUL          <$> anchorify items
 144          ParaQuote{..}   -> ParaQuote type_ <$> anchorify paras
 145          p@ParaArtwork{} -> return p
 146          p@ParaComment{} -> return p
 147 instance Anchorify [ParaItem] where
 148         anchorify = traverse anchorify
 149
 150 instance Anchorify Plain where
 151         anchorify p = do
 152                 State{..} <- S.get
 153                 indexed <-
 154                         if null state_irefs
 155                         then return p
 156                         else traverse anchorify p
 157                 traverse (traverse collect) indexed
 158                 where
 159                 -- TODO: maybe move to Anchorify (Tree PlainNode)
 160                 collect :: PlainNode -> S.State State PlainNode
 161                 collect = \case
 162                  PlainNote{..} -> do
 163                         State{..} <- S.get
 164                         let notes = Map.findWithDefault [] (posAncestors state_section) state_notes
 165                         S.modify $ \s -> s
 166                          { state_notes = Map.insert (posAncestors state_section) (Note state_note note:notes) state_notes
 167                          , state_note  = succNat1 state_note }
 168                         return PlainNote{number=Just state_note, note}
 169                  PlainRref{..} -> do
 170                         State{..} <- S.get
 171                         let anchs = Map.findWithDefault [] to state_rrefs
 172                         let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 173                         let anch = Anchor{count, section=state_section}
 174                         S.modify $ \s -> s{state_rrefs=
 175                                 Map.insert to (anch:anchs) state_rrefs}
 176                         return PlainRref{anchor=Just anch, to}
 177                  n -> return n
 178 instance Anchorify [Para] where
 179         anchorify = traverse anchorify
 180 instance Anchorify [[Para]] where
 181         anchorify = traverse anchorify
 182 instance Anchorify ListItem where
 183         anchorify ListItem{..} = ListItem name <$> anchorify paras
 184 instance Anchorify [ListItem] where
 185         anchorify = traverse anchorify
 186 instance Anchorify (Tree PlainNode) where
 187         anchorify t@(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                  PlainBreak -> return t
 207                  _ -> Tree n <$> traverse anchorify ts
 208
 209 instance Anchorify Title where
 210         anchorify (Title p) = Title <$> anchorify p
 211 instance Anchorify Reference where
 212         anchorify = return
 213 instance Anchorify [Reference] where
 214         anchorify = traverse anchorify
 215
 216 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
 217 indexifyWords section = go mempty
 218         where
 219         go :: Plain -> Irefs -> Words -> (Irefs, Plain)
 220         go acc irefs inp =
 221                 case inp of
 222                  [] -> (irefs, acc)
 223                  Space : next ->
 224                         go (acc |> tree0 (PlainText " ")) irefs next
 225                  Word w : next ->
 226                         case goWords irefs [] inp of
 227                          Nothing -> go (acc |> tree0 (PlainText w)) irefs next
 228                          Just (anch, ls, ns, rs) ->
 229                                 let term = List.reverse ls in
 230                                 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
 231                                 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
 232         goWords ::
 233          Irefs ->
 234          Words -> Words ->
 235          Maybe (Anchor, Words, Words, Irefs)
 236         goWords m@(TreeMap irefsByWord) prev inp =
 237                 case inp of
 238                  [] -> Nothing
 239                  curr@Space : next -> goWords m (curr:prev) next
 240                  curr@(Word w) : next ->
 241                         case Map.lookup w irefsByWord of
 242                          Nothing -> Nothing
 243                          Just nod@TreeMap.Node{..} ->
 244                                 let prev' = curr:prev in
 245                                 case node_value of
 246                                  Strict.Nothing
 247                                   | null node_descendants -> Nothing
 248                                   | otherwise ->
 249                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
 250                                                 (anch, ls, ns, TreeMap $
 251                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 252                                  Strict.Just anchs ->
 253                                         case goWords node_descendants prev' next of
 254                                          Nothing ->
 255                                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
 256                                                 let anch  = Anchor{count, section} in
 257                                                 Just (anch, prev', next, TreeMap $
 258                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
 259                                          Just (anch, ls, ns, rs) ->
 260                                                 Just (anch, ls, ns, TreeMap $
 261                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 262
 263 wordify :: TL.Text -> Words
 264 wordify = List.reverse . go []
 265         where
 266         go :: Words -> TL.Text -> Words
 267         go acc t =
 268                 case TL.span Char.isAlphaNum t of
 269                  ("",_) ->
 270                         case TL.span Char.isSpace t of
 271                          ("",_) ->
 272                                 case TL.uncons t of
 273                                  Nothing -> acc
 274                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
 275                          (_s,r) -> go (Space : acc) r
 276                  (w,r) -> go (Word w : acc) r
 277
 278 plainifyWord :: WordOrSpace -> TL.Text
 279 plainifyWord = \case
 280  Word w -> w
 281  Space  -> " "
 282
 283 plainifyWords :: Words -> TL.Text
 284 plainifyWords = TL.concat . (plainifyWord <$>)
 285
 286 termsByChar :: Terms -> Map Char Terms
 287 termsByChar =
 288         foldr (\aliases acc ->
 289                 case aliases of
 290                  (Word w:_):_ | not (TL.null w) ->
 291                         Map.insertWith (<>)
 292                          (Char.toUpper $ TL.index w 0)
 293                          [aliases] acc
 294                  _ -> acc
 295                 ) Map.empty