Language/DTC/Anchor.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Language.DTC.Anchor where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Category
  10 import Control.Monad (Monad(..), mapM, join)
  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 Language.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 Pos [(Nat1,Para)]
  64
  65 -- * Type 'State'
  66 data State
  67  =   State
  68  {   state_section :: Pos
  69  ,   state_irefs   :: Irefs
  70  ,   state_rrefs   :: Rrefs
  71  ,   state_notes   :: Notes
  72  }
  73 instance Default State where
  74         def = State
  75          { state_section = def
  76          , state_irefs   = mempty
  77          , state_rrefs   = mempty
  78          , state_notes   = mempty
  79          }
  80
  81 -- * Class 'Anchorify'
  82 class Anchorify a where
  83         anchorify :: a -> S.State State a
  84 instance Anchorify (Tree a) => Anchorify [Tree a] where
  85         anchorify = mapM anchorify
  86 instance Anchorify Body where
  87         anchorify = mapM anchorify
  88 instance Anchorify (Tree BodyNode) where
  89         anchorify = \case
  90          Tree n ts ->
  91                 case n of
  92                  Section{..} -> do
  93                         before@State{state_section} <- S.get
  94                         S.put before{state_section = pos}
  95                         t <- Tree <$> anchorify n <*> anchorify ts
  96                         after <- S.get
  97                         S.put after{state_section}
  98                         return t
  99                  _ -> Tree <$> anchorify n <*> anchorify ts
 100 instance Anchorify BodyNode where
 101         anchorify = \case
 102          Section{..} ->
 103                 Section pos attrs
 104                  <$> anchorify title
 105                  <*> pure aliases
 106          d@ToC{}   -> pure d
 107          d@ToF{}   -> pure d
 108          d@Index{} -> pure d
 109          Figure{..} ->
 110                 Figure pos attrs type_
 111                  <$> anchorify mayTitle
 112                  <*> anchorify blocks
 113          References{..} ->
 114                 References pos attrs
 115                  <$> anchorify refs
 116          Block v ->
 117                 Block <$> anchorify v
 118 instance Anchorify a => Anchorify (Maybe a) where
 119         anchorify = mapM anchorify
 120 instance Anchorify [Reference] where
 121         anchorify = mapM anchorify
 122 instance Anchorify [Block] where
 123         anchorify = mapM anchorify
 124 instance Anchorify [[Block]] where
 125         anchorify = mapM (mapM anchorify)
 126 instance Anchorify Title where
 127         anchorify (Title t) = Title <$> anchorify t
 128 instance Anchorify Block where
 129         anchorify = \case
 130          Para{..}    -> Para    pos attrs <$> anchorify para
 131          OL{..}      -> OL      pos attrs <$> anchorify items
 132          UL{..}      -> UL      pos attrs <$> anchorify items
 133          Quote{..}   -> Quote   pos attrs type_ <$> anchorify blocks
 134          d@Artwork{} -> pure d
 135          d@Comment{} -> pure d
 136 instance Anchorify Para where
 137         anchorify ls = do
 138                 State{..} <- S.get
 139                 indexed <-
 140                         if null state_irefs
 141                         then return ls
 142                         else join <$> traverse indexifyLines ls
 143                 traverse go indexed
 144                 where
 145                 go :: Lines -> S.State State Lines
 146                 go t =
 147                         case t of
 148                          Tree n ts ->
 149                                 Tree
 150                                  <$> (case n of
 151                                          Note{..} -> do
 152                                                 State{..} <- S.get
 153                                                 let notes = Map.findWithDefault [] state_section state_notes
 154                                                 let count | (cnt,_):_ <- notes = succNat1 cnt
 155                                                           | otherwise = Nat1 1
 156                                                 S.modify $ \s -> s{state_notes=
 157                                                         Map.insert state_section ((count,ts):notes) state_notes}
 158                                                 return Note{number=Just count}
 159                                          Rref{..} -> do
 160                                                 State{..} <- S.get
 161                                                 let anchs = Map.findWithDefault [] to state_rrefs
 162                                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 163                                                 let anch = Anchor{count, section=state_section}
 164                                                 S.modify $ \s -> s{state_rrefs=
 165                                                         Map.insert to (anch:anchs) state_rrefs}
 166                                                 return Rref{anchor=Just anch, to}
 167                                          _ -> return n)
 168                                  <*> traverse go ts
 169 instance Anchorify Reference where
 170         anchorify = return
 171
 172 indexifyLines :: Lines -> S.State State Para
 173 indexifyLines = \case
 174  Tree n@Iref{term} ts
 175   | Just words <- pathFromWords term -> do
 176         State{state_irefs, state_section} <- S.get
 177         case TreeMap.lookup words state_irefs of
 178          Strict.Nothing ->
 179                 Seq.singleton . Tree n . join
 180                  <$> traverse indexifyLines ts
 181          Strict.Just anchs -> do
 182                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 183                 let anch = Anchor{count, section=state_section}
 184                 S.modify $ \s -> s{state_irefs=
 185                         TreeMap.insert const words (anch:anchs) state_irefs}
 186                 Seq.singleton . Tree Iref{term, anchor=Just anch} . join
 187                  <$> traverse indexifyLines ts
 188  Tree BR _ -> pure $ Seq.singleton $ tree0 BR
 189  Tree (Plain p) _ -> do
 190         State{..} <- S.get
 191         let (irefs,ts) = indexifyWords state_section state_irefs (wordify p)
 192         S.modify $ \s -> s{state_irefs=irefs}
 193         return ts
 194  Tree n ts ->
 195         Seq.singleton . Tree n . join
 196          <$> traverse indexifyLines ts
 197
 198 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Para)
 199 indexifyWords section = go mempty
 200         where
 201         go :: Para -> Irefs -> Words -> (Irefs, Para)
 202         go acc irefs inp =
 203                 case inp of
 204                  [] -> (irefs, acc)
 205                  Space : next ->
 206                         go (acc |> tree0 (Plain " ")) irefs next
 207                  Word w : next ->
 208                         case goWords irefs [] inp of
 209                          Nothing -> go (acc |> tree0 (Plain w)) irefs next
 210                          Just (anch, ls, ns, rs) ->
 211                                 let term = List.reverse ls in
 212                                 let lines = Seq.fromList $ tree0 . Plain . plainifyWord <$> term in
 213                                 go (acc |> Tree Iref{term, anchor=Just anch} lines) rs ns
 214         goWords ::
 215          Irefs ->
 216          Words -> Words ->
 217          Maybe (Anchor, Words, Words, Irefs)
 218         goWords m@(TreeMap irefsByWord) prev inp =
 219                 case inp of
 220                  [] -> Nothing
 221                  curr@Space : next -> goWords m (curr:prev) next
 222                  curr@(Word w) : next ->
 223                         case Map.lookup w irefsByWord of
 224                          Nothing -> Nothing
 225                          Just nod@TreeMap.Node{..} ->
 226                                 let prev' = curr:prev in
 227                                 case node_value of
 228                                  Strict.Nothing
 229                                   | null node_descendants -> Nothing
 230                                   | otherwise ->
 231                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
 232                                                 (anch, ls, ns, TreeMap $
 233                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 234                                  Strict.Just anchs ->
 235                                         case goWords node_descendants prev' next of
 236                                          Nothing ->
 237                                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
 238                                                 let anch  = Anchor{count, section} in
 239                                                 Just (anch, prev', next, TreeMap $
 240                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
 241                                          Just (anch, ls, ns, rs) ->
 242                                                 Just (anch, ls, ns, TreeMap $
 243                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 244
 245 wordify :: TL.Text -> Words
 246 wordify = List.reverse . go []
 247         where
 248         go :: Words -> TL.Text -> Words
 249         go acc t =
 250                 case TL.span Char.isAlphaNum t of
 251                  ("",_) ->
 252                         case TL.span Char.isSpace t of
 253                          ("",_) ->
 254                                 case TL.uncons t of
 255                                  Nothing -> acc
 256                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
 257                          (_s,r) -> go (Space : acc) r
 258                  (w,r) -> go (Word w : acc) r
 259
 260 plainifyWord :: WordOrSpace -> TL.Text
 261 plainifyWord = \case
 262  Word w -> w
 263  Space  -> " "
 264
 265 plainifyWords :: Words -> TL.Text
 266 plainifyWords = TL.concat . (plainifyWord <$>)
 267
 268 termsByChar :: Terms -> Map Char Terms
 269 termsByChar =
 270         foldr (\aliases acc ->
 271                 case aliases of
 272                  (Word w:_):_ | not (TL.null w) ->
 273                         Map.insertWith (<>)
 274                          (Char.toUpper $ TL.index w 0)
 275                          [aliases] acc
 276                  _ -> acc
 277                 ) Map.empty