{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hdoc.DTC.Anchor where import Control.Applicative (Applicative(..)) import Control.Category import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) import Data.Default.Class (Default(..)) import Data.Foldable (Foldable(..), concat) import Data.Function (($), const) import Data.Functor ((<$>)) import Data.Map.Strict (Map) import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence ((|>)) import Data.Traversable (Traversable(..)) import Data.TreeMap.Strict (TreeMap(..)) import Data.TreeSeq.Strict (Tree(..), tree0) import qualified Control.Monad.Trans.State as S import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Strict.Maybe as Strict import qualified Data.Text.Lazy as TL import qualified Data.TreeMap.Strict as TreeMap -- import qualified Data.TreeSeq.Strict as TreeSeq import Hdoc.DTC.Document -- * Type 'PathWord' type PathWord = TreeMap.Path Word pathFromWords :: Words -> Maybe PathWord pathFromWords ws = case ws >>= unSpace of p:ps | not (TL.null p) -> Just (TreeMap.path p ps) _ -> Nothing where unSpace = \case Space -> [] Word w -> [w] -- * Type 'Irefs' type Irefs = TreeMap Word [Anchor] irefsOfTerms :: Terms -> Irefs irefsOfTerms = TreeMap.fromList const . (>>= f) . concat where f [] = [] f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws -- * Type 'Rrefs' type Rrefs = Map Ident [Anchor] -- * Type 'Notes' type Notes = Map PosPath [Note] data Note = Note { note_number :: Nat1 , note_content :: [Para] } -- deriving (Eq,Show) -- * Type 'State' data State = State { state_section :: Pos , state_irefs :: Irefs , state_rrefs :: Rrefs , state_notes :: Notes , state_note :: Nat1 } instance Default State where def = State { state_section = def , state_irefs = mempty , state_rrefs = def , state_notes = def , state_note = def } -- * Class 'Anchorify' class Anchorify a where anchorify :: a -> S.State State a instance Anchorify a => Anchorify (Maybe a) where anchorify = traverse anchorify instance Anchorify Body where anchorify = traverse anchorify instance Anchorify (Tree BodyNode) where anchorify = \case Tree n ts -> case n of BodySection{..} -> do before@State{state_section} <- S.get S.put before{state_section = pos} t <- Tree <$> anchorify n <*> anchorify ts after <- S.get S.put after{state_section} return t BodyBlock{} -> tree0 <$> anchorify n instance Anchorify BodyNode where anchorify = \case BodySection{..} -> BodySection pos attrs <$> anchorify title <*> pure aliases <*> traverse anchorify judgments BodyBlock b -> BodyBlock <$> anchorify b instance Anchorify Block where anchorify = \case BlockPara p -> BlockPara <$> anchorify p b@BlockBreak{} -> return b b@BlockToC{} -> return b b@BlockToF{} -> return b b@BlockIndex{} -> return b BlockAside{..} -> BlockAside pos attrs <$> traverse anchorify blocks BlockFigure{..} -> BlockFigure pos type_ attrs <$> anchorify mayTitle <*> traverse anchorify paras BlockReferences{..} -> BlockReferences pos attrs <$> traverse anchorify refs BlockJudges{..} -> BlockJudges pos attrs <$> traverse anchorify jury BlockGrades{..} -> BlockGrades pos attrs <$> traverse anchorify scale instance Anchorify Para where anchorify = \case ParaItem{..} -> ParaItem <$> anchorify item ParaItems{..} -> ParaItems pos attrs <$> traverse anchorify items instance Anchorify ParaItem where anchorify = \case ParaPlain plain -> ParaPlain <$> anchorify plain ParaOL items -> ParaOL <$> traverse anchorify items ParaUL items -> ParaUL <$> traverse (traverse anchorify) items ParaQuote{..} -> ParaQuote type_ <$> traverse anchorify paras p@ParaArtwork{} -> return p p@ParaComment{} -> return p ParaJudgment j -> ParaJudgment <$> anchorify j instance Anchorify ListItem where anchorify ListItem{..} = ListItem name <$> traverse anchorify paras instance Anchorify Judgment where anchorify Judgment{..} = Judgment judges grades importance <$> anchorify question <*> traverse anchorify choices instance Anchorify Plain where anchorify p = do State{..} <- S.get indexed <- if null state_irefs then return p else traverse anchorify p traverse (traverse collect) indexed where -- TODO: maybe move to Anchorify (Tree PlainNode) collect :: PlainNode -> S.State State PlainNode collect = \case PlainNote{..} -> do State{..} <- S.get let notes = Map.findWithDefault [] (pos_Ancestors state_section) state_notes S.modify $ \s -> s { state_notes = Map.insert (pos_Ancestors state_section) (Note state_note note:notes) state_notes , state_note = succNat1 state_note } return PlainNote{number=Just state_note, note} PlainRref{..} -> do State{..} <- S.get let anchs = Map.findWithDefault [] to state_rrefs let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c let anch = Anchor{count, section=state_section} S.modify $ \s -> s{state_rrefs= Map.insert to (anch:anchs) state_rrefs} return PlainRref{anchor=Just anch, to} n -> return n instance Anchorify (Tree PlainNode) where anchorify (Tree n ts) = case n of PlainIref{term} | Just words <- pathFromWords term -> do State{state_irefs, state_section} <- S.get case TreeMap.lookup words state_irefs of Strict.Nothing -> Tree n <$> traverse anchorify ts Strict.Just anchs -> do let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c let anch = Anchor{count, section=state_section} S.modify $ \s -> s{state_irefs= TreeMap.insert const words (anch:anchs) state_irefs} Tree PlainIref{term, anchor=Just anch} <$> traverse anchorify ts PlainText txt -> do State{..} <- S.get let (irefs,para) = indexifyWords state_section state_irefs (wordify txt) S.modify $ \s -> s{state_irefs=irefs} return $ Tree PlainGroup para _ -> Tree n <$> traverse anchorify ts instance Anchorify Title where anchorify (Title p) = Title <$> anchorify p instance Anchorify Reference where anchorify = return instance Anchorify Choice where anchorify Choice{..} = Choice <$> anchorify title <*> traverse anchorify opinions instance Anchorify Opinion where anchorify Opinion{..} = Opinion judge grade importance <$> anchorify comment instance Anchorify Grade where anchorify Grade{..} = Grade pos name color isDefault <$> anchorify title instance Anchorify Judge where anchorify Judge{..} = Judge name <$> anchorify title <*> pure defaultGrades indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain) indexifyWords section = go mempty where go :: Plain -> Irefs -> Words -> (Irefs, Plain) go acc irefs inp = case inp of [] -> (irefs, acc) Space : next -> go (acc |> tree0 (PlainText " ")) irefs next Word w : next -> case goWords irefs [] inp of Nothing -> go (acc |> tree0 (PlainText w)) irefs next Just (anch, ls, ns, rs) -> let term = List.reverse ls in let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns goWords :: Irefs -> Words -> Words -> Maybe (Anchor, Words, Words, Irefs) goWords m@(TreeMap irefsByWord) prev inp = case inp of [] -> Nothing curr@Space : next -> goWords m (curr:prev) next curr@(Word w) : next -> case Map.lookup w irefsByWord of Nothing -> Nothing Just nod@TreeMap.Node{..} -> let prev' = curr:prev in case node_value of Strict.Nothing | null node_descendants -> Nothing | otherwise -> (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) -> (anch, ls, ns, TreeMap $ Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord) Strict.Just anchs -> case goWords node_descendants prev' next of Nothing -> let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in let anch = Anchor{count, section} in Just (anch, prev', next, TreeMap $ Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord) Just (anch, ls, ns, rs) -> Just (anch, ls, ns, TreeMap $ Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord) wordify :: TL.Text -> Words wordify = List.reverse . go [] where go :: Words -> TL.Text -> Words go acc t = case TL.span Char.isAlphaNum t of ("",_) -> case TL.span Char.isSpace t of ("",_) -> case TL.uncons t of Nothing -> acc Just (c,r) -> go (Word (TL.singleton c) : acc) r (_s,r) -> go (Space : acc) r (w,r) -> go (Word w : acc) r plainifyWord :: WordOrSpace -> TL.Text plainifyWord = \case Word w -> w Space -> " " plainifyWords :: Words -> TL.Text plainifyWords = TL.concat . (plainifyWord <$>) termsByChar :: Terms -> Map Char Terms termsByChar = foldr (\aliases acc -> case aliases of (Word w:_):_ | not (TL.null w) -> Map.insertWith (<>) (Char.toUpper $ TL.index w 0) [aliases] acc _ -> acc ) Map.empty