Language/DTC/Anchor.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 -- | Compute an Index for a DTC.
   7 module Language.DTC.Anchor where
   8
   9 import Control.Applicative (Applicative(..))
  10 import Control.Category
  11 import Control.Monad (Monad(..), mapM, join)
  12 import Data.Bool
  13 import Data.Char (Char)
  14 import Data.Default.Class (Default(..))
  15 import Data.Foldable (Foldable(..), concat)
  16 import Data.Function (($), const)
  17 import Data.Functor ((<$>))
  18 import Data.Map.Strict (Map)
  19 import Data.Maybe (Maybe(..), maybe)
  20 import Data.Monoid (Monoid(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Sequence ((|>))
  23 import Data.Text (Text)
  24 import Data.Traversable (Traversable(..))
  25 import Data.TreeMap.Strict (TreeMap(..))
  26 import Data.TreeSeq.Strict (Tree(..))
  27 import qualified Control.Monad.Trans.State as S
  28 import qualified Data.Char as Char
  29 import qualified Data.List as List
  30 import qualified Data.Map.Strict as Map
  31 import qualified Data.Sequence as Seq
  32 import qualified Data.Strict.Maybe as Strict
  33 import qualified Data.Text as Text
  34 import qualified Data.TreeMap.Strict as TreeMap
  35
  36 import Language.DTC.Document
  37
  38 -- ** Type 'PathWord'
  39 type PathWord = TreeMap.Path Word
  40
  41 pathFromWords :: Words -> Maybe PathWord
  42 pathFromWords ws =
  43         case ws >>= unSpace of
  44          p:ps | not (Text.null p) -> Just (TreeMap.path p ps)
  45          _ -> Nothing
  46         where
  47         unSpace = \case
  48          Space  -> []
  49          Word w -> [w]
  50
  51 -- ** Type 'Irefs'
  52 type Irefs = TreeMap Word [Anchor]
  53
  54 irefsOfTerms :: Terms -> Irefs
  55 irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
  56         where
  57         f [] = []
  58         f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
  59
  60 -- * Type 'State'
  61 data State
  62  =   State
  63  {   state_irefs   :: Irefs
  64  ,   state_section :: Pos
  65  }
  66 state :: State
  67 state = State
  68  { state_irefs   = mempty
  69  , state_section = def
  70  }
  71
  72 -- * Class 'Anchorify'
  73 class Anchorify a where
  74         anchorify :: a -> S.State State a
  75 instance Anchorify (Tree k a) => Anchorify [Tree k a] where
  76         anchorify = mapM anchorify
  77 instance Anchorify (Tree BodyKey BodyValue) where
  78         anchorify = \case
  79          Tree0 v -> Tree0 <$> anchorify v
  80          TreeN k v ->
  81                 case k of
  82                  Section{..} -> do
  83                         before@State{state_section} <- S.get
  84                         S.put before{state_section = pos}
  85                         t <- TreeN <$> anchorify k <*> anchorify v
  86                         after <- S.get
  87                         S.put after{state_section}
  88                         return t
  89 instance Anchorify Body where
  90         anchorify b = do
  91                 State{..} <- S.get
  92                 case () of
  93                  () | null state_irefs -> return b
  94                  _ -> mapM anchorify b
  95 instance Anchorify BodyKey where
  96         anchorify = \case
  97          Section{..} ->
  98                 Section pos attrs
  99                  <$> anchorify title
 100                  <*> pure aliases
 101 instance Anchorify BodyValue where
 102         anchorify = \case
 103          d@ToC{} -> pure d
 104          d@ToF{} -> pure d
 105          d@Index{} -> pure d
 106          Figure{..} ->
 107                 Figure pos attrs type_
 108                  <$> anchorify title
 109                  <*> anchorify blocks
 110          Block v ->
 111                 Block <$> anchorify v
 112 instance Anchorify [Reference] where
 113         anchorify = mapM anchorify
 114 instance Anchorify [Block] where
 115         anchorify = mapM anchorify
 116 instance Anchorify [[Block]] where
 117         anchorify = mapM (mapM anchorify)
 118 instance Anchorify Title where
 119         anchorify (Title t) = Title <$> anchorify t
 120 instance Anchorify Block where
 121         anchorify = \case
 122          Para{..}    -> Para    pos attrs <$> anchorify para
 123          OL{..}      -> OL      pos attrs <$> anchorify items
 124          UL{..}      -> UL      pos attrs <$> anchorify items
 125          RL{..}      -> RL      pos attrs <$> anchorify refs
 126          Artwork{..} -> Artwork pos attrs <$> anchorify art
 127          d@Comment{} -> pure d
 128 instance Anchorify Para where
 129         anchorify ls = do
 130                 join <$> traverse indexifyLines ls
 131 instance Anchorify Reference where
 132         anchorify = return
 133 instance Anchorify Artwork where
 134         anchorify = return
 135
 136 indexifyLines :: Lines -> S.State State Para
 137 indexifyLines = \case
 138  Tree0 a -> indexifyPlain a
 139  TreeN k@Iref{term} ts
 140   | Just words <- pathFromWords term -> do
 141         State{state_irefs, state_section} <- S.get
 142         case TreeMap.lookup words state_irefs of
 143          Strict.Nothing ->
 144                 Seq.singleton . TreeN k . join
 145                  <$> traverse indexifyLines ts
 146          Strict.Just irefs -> do
 147                 let count = case irefs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 148                 let anch = Anchor{count, section=state_section}
 149                 S.modify $ \s -> s{state_irefs=
 150                         TreeMap.insert const words (anch:irefs) state_irefs}
 151                 Seq.singleton . TreeN Iref{term, anchor=Just anch} . join
 152                  <$> traverse indexifyLines ts
 153  TreeN k ts ->
 154         Seq.singleton . TreeN k . join
 155          <$> traverse indexifyLines ts
 156
 157 indexifyPlain :: LineValue -> S.State State Para
 158 indexifyPlain = \case
 159  BR -> pure $ Seq.singleton $ Tree0 BR
 160  Plain p -> do
 161         State{..} <- S.get
 162         let (irefs,ts) = indexifyWords state_section state_irefs (wordify p)
 163         S.modify $ \s -> s{state_irefs=irefs}
 164         return ts
 165
 166 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Para)
 167 indexifyWords section = go mempty
 168         where
 169         go :: Para -> Irefs -> Words -> (Irefs, Para)
 170         go acc irefs inp =
 171                 case inp of
 172                  [] -> (irefs, acc)
 173                  Space : next ->
 174                         go (acc |> Tree0 (Plain " ")) irefs next
 175                  Word w : next ->
 176                         case goWords irefs [] inp of
 177                          Nothing -> go (acc |> Tree0 (Plain w)) irefs next
 178                          Just (anch, ls, ns, rs) ->
 179                                 let term = List.reverse ls in
 180                                 let lines = Seq.fromList $ Tree0 . Plain . plainifyWord <$> term in
 181                                 go (acc |> TreeN Iref{term, anchor=Just anch} lines) rs ns
 182         goWords ::
 183          Irefs ->
 184          Words -> Words ->
 185          Maybe (Anchor, Words, Words, Irefs)
 186         goWords m@(TreeMap irefsByWord) prev inp =
 187                 case inp of
 188                  [] -> Nothing
 189                  curr@Space : next -> goWords m (curr:prev) next
 190                  curr@(Word w) : next ->
 191                         case Map.lookup w irefsByWord of
 192                          Nothing -> Nothing
 193                          Just nod@TreeMap.Node{..} ->
 194                                 let prev' = curr:prev in
 195                                 case node_value of
 196                                  Strict.Nothing
 197                                   | null node_descendants -> Nothing
 198                                   | otherwise ->
 199                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
 200                                                 (anch, ls, ns, TreeMap $
 201                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 202                                  Strict.Just irefs ->
 203                                         case goWords node_descendants prev' next of
 204                                          Nothing ->
 205                                                 let count = case irefs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
 206                                                 let anch  = Anchor{count, section} in
 207                                                 Just (anch, prev', next, TreeMap $
 208                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:irefs} irefsByWord)
 209                                          Just (anch, ls, ns, rs) ->
 210                                                 Just (anch, ls, ns, TreeMap $
 211                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 212
 213 wordify :: Text -> Words
 214 wordify = List.reverse . go []
 215         where
 216         go :: Words -> Text -> Words
 217         go acc t =
 218                 case Text.span Char.isAlphaNum t of
 219                  ("",_) ->
 220                         case Text.span Char.isSpace t of
 221                          ("",_) ->
 222                                 case Text.uncons t of
 223                                  Nothing -> acc
 224                                  Just (c,r) -> go (Word (Text.singleton c) : acc) r
 225                          (_s,r) -> go (Space : acc) r
 226                  (w,r) -> go (Word w : acc) r
 227
 228 plainifyWord :: WordOrSpace -> Text
 229 plainifyWord = \case
 230  Word w -> w
 231  Space  -> " "
 232
 233 plainifyWords :: Words -> Text
 234 plainifyWords = Text.concat . (plainifyWord <$>)
 235
 236 termsByChar :: Terms -> Map Char Terms
 237 termsByChar =
 238         foldr (\aliases acc ->
 239                 case aliases of
 240                  (Word w:_):_ | not (Text.null w) ->
 241                         Map.insertWith (<>)
 242                          (Char.toUpper $ Text.index w 0)
 243                          [aliases] acc
 244                  _ -> acc
 245                 ) Map.empty