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