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