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 ListItem where
 182         anchorify ListItem{..} = ListItem name <$> anchorify paras
 183 instance Anchorify [ListItem] where
 184         anchorify = traverse anchorify
 185 instance Anchorify (Tree PlainNode) where
 186         anchorify t@(Tree n ts) =
 187                 case n of
 188                  PlainIref{term} | Just words <- pathFromWords term -> do
 189                         State{state_irefs, state_section} <- S.get
 190                         case TreeMap.lookup words state_irefs of
 191                          Strict.Nothing ->
 192                                 Tree n <$> traverse anchorify ts
 193                          Strict.Just anchs -> do
 194                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 195                                 let anch = Anchor{count, section=state_section}
 196                                 S.modify $ \s -> s{state_irefs=
 197                                         TreeMap.insert const words (anch:anchs) state_irefs}
 198                                 Tree PlainIref{term, anchor=Just anch}
 199                                  <$> traverse anchorify ts
 200                  PlainText txt -> do
 201                         State{..} <- S.get
 202                         let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
 203                         S.modify $ \s -> s{state_irefs=irefs}
 204                         return $ Tree PlainGroup para
 205                  PlainBR -> return t
 206                  _ -> Tree n <$> traverse anchorify ts
 207
 208 instance Anchorify Title where
 209         anchorify (Title p) = Title <$> anchorify p
 210 instance Anchorify Reference where
 211         anchorify = return
 212 instance Anchorify [Reference] where
 213         anchorify = traverse anchorify
 214
 215 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
 216 indexifyWords section = go mempty
 217         where
 218         go :: Plain -> Irefs -> Words -> (Irefs, Plain)
 219         go acc irefs inp =
 220                 case inp of
 221                  [] -> (irefs, acc)
 222                  Space : next ->
 223                         go (acc |> tree0 (PlainText " ")) irefs next
 224                  Word w : next ->
 225                         case goWords irefs [] inp of
 226                          Nothing -> go (acc |> tree0 (PlainText w)) irefs next
 227                          Just (anch, ls, ns, rs) ->
 228                                 let term = List.reverse ls in
 229                                 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
 230                                 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
 231         goWords ::
 232          Irefs ->
 233          Words -> Words ->
 234          Maybe (Anchor, Words, Words, Irefs)
 235         goWords m@(TreeMap irefsByWord) prev inp =
 236                 case inp of
 237                  [] -> Nothing
 238                  curr@Space : next -> goWords m (curr:prev) next
 239                  curr@(Word w) : next ->
 240                         case Map.lookup w irefsByWord of
 241                          Nothing -> Nothing
 242                          Just nod@TreeMap.Node{..} ->
 243                                 let prev' = curr:prev in
 244                                 case node_value of
 245                                  Strict.Nothing
 246                                   | null node_descendants -> Nothing
 247                                   | otherwise ->
 248                                         (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
 249                                                 (anch, ls, ns, TreeMap $
 250                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 251                                  Strict.Just anchs ->
 252                                         case goWords node_descendants prev' next of
 253                                          Nothing ->
 254                                                 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
 255                                                 let anch  = Anchor{count, section} in
 256                                                 Just (anch, prev', next, TreeMap $
 257                                                         Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
 258                                          Just (anch, ls, ns, rs) ->
 259                                                 Just (anch, ls, ns, TreeMap $
 260                                                         Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
 261
 262 wordify :: TL.Text -> Words
 263 wordify = List.reverse . go []
 264         where
 265         go :: Words -> TL.Text -> Words
 266         go acc t =
 267                 case TL.span Char.isAlphaNum t of
 268                  ("",_) ->
 269                         case TL.span Char.isSpace t of
 270                          ("",_) ->
 271                                 case TL.uncons t of
 272                                  Nothing -> acc
 273                                  Just (c,r) -> go (Word (TL.singleton c) : acc) r
 274                          (_s,r) -> go (Space : acc) r
 275                  (w,r) -> go (Word w : acc) r
 276
 277 plainifyWord :: WordOrSpace -> TL.Text
 278 plainifyWord = \case
 279  Word w -> w
 280  Space  -> " "
 281
 282 plainifyWords :: Words -> TL.Text
 283 plainifyWords = TL.concat . (plainifyWord <$>)
 284
 285 termsByChar :: Terms -> Map Char Terms
 286 termsByChar =
 287         foldr (\aliases acc ->
 288                 case aliases of
 289                  (Word w:_):_ | not (TL.null w) ->
 290                         Map.insertWith (<>)
 291                          (Char.toUpper $ TL.index w 0)
 292                          [aliases] acc
 293                  _ -> acc
 294                 ) Map.empty