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