1-- | This module implements a "flattening" pass over RichText 'Inline'
2-- values. This means that a tree structure such as
3--
4-- @
5--   EStrong
6--     [ EStrikethrough
7--       [ EText "inside"
8--       ]
9--     , EText "outside"
10--     ]
11-- @
12--
13-- will be converted into a "flat" representation without a tree
14-- structure so that the style information encoded in the tree is
15-- available at each node:
16--
17-- @
18--   [
19--     [ SingleInline (FlattenedInline (FText "inside") [Strong, Strikethrough] Nothing
20--     , SingleInline (FlattenedInline (FText "outside") [Strong] Nothing
21--     ]
22--   ]
23-- @
24--
25-- The outer sequence is a sequence of lines (since inline lists can
26-- introduce line breaks). Each inner sequence is a single line.
27-- Each 'SingleInline' can be rendered as-is; if a 'NonBreaking' is
28-- encountered, that group of inlines should be treated as a unit for
29-- the purposes of line-wrapping (to happen in the Wrap module). The
30-- above representation example shows how the tree path including the
31-- 'EStrong' and 'EStrikethrough' nodes is flattened into a list of
32-- styles to accompany each inline value. This makes it trivial to carry
33-- that style information along with each node during line-wrapping
34-- rather than needing to deal with the tree structure.
35module Matterhorn.Draw.RichText.Flatten
36  ( FlattenedContent(..)
37  , FlattenedInline(..)
38  , InlineStyle(..)
39  , FlattenedValue(..)
40  , flattenInlineSeq
41  )
42where
43
44import           Prelude ()
45import           Matterhorn.Prelude
46
47import           Control.Monad.Reader
48import           Control.Monad.State
49import           Data.List ( nub )
50import qualified Data.Sequence as Seq
51import           Data.Sequence ( ViewL(..)
52                               , ViewR(..)
53                               , (<|)
54                               , (|>)
55                               )
56import qualified Data.Set as Set
57import qualified Data.Text as T
58
59import           Matterhorn.Constants ( normalChannelSigil, userSigil )
60import           Matterhorn.Types ( HighlightSet(..), SemEq(..) )
61import           Matterhorn.Types.RichText
62
63
64-- | A piece of text in a sequence of flattened RichText elements. This
65-- type represents the lowest-level kind of data that we can get from a
66-- rich text document.
67data FlattenedContent =
68    FText Text
69    -- ^ Some text
70    | FSpace
71    -- ^ A space
72    | FUser Text
73    -- ^ A user reference
74    | FChannel Text
75    -- ^ A channel reference
76    | FEmoji Text
77    -- ^ An emoji
78    | FEditSentinel Bool
79    -- ^ An "edited" marking
80    deriving (Eq, Show)
81
82-- | A flattened inline value.
83data FlattenedInline a =
84    FlattenedInline { fiValue :: FlattenedContent
85                    -- ^ The content of the value.
86                    , fiStyles :: [InlineStyle]
87                    -- ^ The styles that should be applied to this
88                    -- value.
89                    , fiURL :: Maybe URL
90                    -- ^ If present, the URL to which we should
91                    -- hyperlink this value.
92                    , fiName :: Maybe a
93                    -- ^ The resource name, if any, that should be used
94                    -- to make this inline clickable once rendered.
95                    }
96                    deriving (Show)
97
98-- | A flattened value.
99data FlattenedValue a =
100    SingleInline (FlattenedInline a)
101    -- ^ A single flattened value
102    | NonBreaking (Seq (Seq (FlattenedValue a)))
103    -- ^ A sequence of flattened values that MUST be kept together and
104    -- never broken up by line-wrapping
105    deriving (Show)
106
107-- | The visual styles of inline values.
108data InlineStyle =
109    Strong
110    | Emph
111    | Strikethrough
112    | Code
113    | Permalink
114    deriving (Eq, Show)
115
116type FlattenM n a = ReaderT (FlattenEnv n) (State (FlattenState n)) a
117
118-- | The flatten monad state
119data FlattenState a =
120    FlattenState { fsCompletedLines :: Seq (Seq (FlattenedValue a))
121                 -- ^ The lines that we have accumulated so far in the
122                 -- flattening process
123                 , fsCurLine :: Seq (FlattenedValue a)
124                 -- ^ The current line we are accumulating in the
125                 -- flattening process
126                 , fsNameIndex :: Int
127                 -- ^ The index used to generate a new unique name (of
128                 -- type 'a') to make a region of text clickable.
129                 }
130
131-- | The flatten monad environment
132data FlattenEnv a =
133    FlattenEnv { flattenStyles :: [InlineStyle]
134               -- ^ The styles that should apply to the current value
135               -- being flattened
136               , flattenURL :: Maybe URL
137               -- ^ The hyperlink URL, if any, that should be applied to
138               -- the current value being flattened
139               , flattenHighlightSet :: HighlightSet
140               -- ^ The highlight set to use to check for valid user or
141               -- channel references
142               , flattenNameGen :: Maybe (Int -> Inline -> Maybe a)
143               -- ^ The function to use to generate resource names
144               -- for clickable inlines. If provided, this is used to
145               -- determine whether a given Inline should be augmented
146               -- with a resource name.
147               , flattenNameFunc :: Maybe (Int -> Maybe a)
148               -- ^ The currently active function to generate a resource
149               -- name for any inline. In practice this is just the
150               -- value of flattenNameGen, but partially applied with a
151               -- specific Inline prior to flattening that Inline.
152               }
153
154-- | Given a sequence of inlines, flatten it into a list of lines of
155-- flattened values.
156--
157-- The flattening process also validates user and channel references
158-- against a 'HighlightSet'. For example, if an 'EUser' node is found,
159-- its username argument is looked up in the 'HighlightSet'. If the
160-- username is found, the 'EUser' node is preserved as an 'FUser' node.
161-- Otherwise it is rewritten as an 'FText' node so that the username
162-- does not get highlighted. Channel references ('EChannel') are handled
163-- similarly.
164--
165-- The optional name generator function argument is used to assign
166-- resource names to each inline that should be clickable once rendered.
167-- The result of the name generator function will be stored in the
168-- 'fiName' field of each 'FlattenedInline' that results from calling
169-- that function on an 'Inline'.
170flattenInlineSeq :: SemEq a
171                 => HighlightSet
172                 -> Maybe (Int -> Inline -> Maybe a)
173                 -- ^ A name generator function for clickable inlines.
174                 -- The integer argument is a unique (to this inline
175                 -- sequence) sequence number.
176                 -> Inlines
177                 -> Seq (Seq (FlattenedValue a))
178flattenInlineSeq hs nameGen is =
179    snd $ flattenInlineSeq' initialEnv 0 is
180    where
181        initialEnv = FlattenEnv { flattenStyles = []
182                                , flattenURL = Nothing
183                                , flattenHighlightSet = hs
184                                , flattenNameGen = nameGen
185                                , flattenNameFunc = Nothing
186                                }
187
188flattenInlineSeq' :: SemEq a
189                  => FlattenEnv a
190                  -> Int
191                  -> Inlines
192                  -> (Int, Seq (Seq (FlattenedValue a)))
193flattenInlineSeq' env c is =
194    (fsNameIndex finalState, fsCompletedLines finalState)
195    where
196        finalState = execState stBody initialState
197        initialState = FlattenState { fsCompletedLines = mempty
198                                    , fsCurLine = mempty
199                                    , fsNameIndex = c
200                                    }
201        stBody = runReaderT body env
202        body = do
203            flattenInlines is
204            pushFLine
205
206flattenInlines :: SemEq a => Inlines -> FlattenM a ()
207flattenInlines is = do
208    pairs <- nameInlinePairs
209    mapM_ wrapFlatten pairs
210    where
211        wrapFlatten (nameFunc, i) = withNameFunc nameFunc $ flatten i
212
213        -- For each inline, prior to flattening it, obtain the resource
214        -- name (if any) that should be assigned to each flattened
215        -- fragment of the inline.
216        nameInlinePairs = forM (unInlines is) $ \i -> do
217            nameFunc <- nameGenWrapper i
218            return (nameFunc, i)
219
220        -- Determine whether the name generation function will produce
221        -- a name for this inline. If it does (using a fake sequence
222        -- number) then return a new name generation function to use for
223        -- all flattened fragments of this inline.
224        nameGenWrapper :: Inline -> FlattenM a (Maybe (Int -> Maybe a))
225        nameGenWrapper i = do
226            c <- gets fsNameIndex
227            nameGen <- asks flattenNameGen
228            return $ case nameGen of
229                Nothing -> Nothing
230                Just f -> if isJust (f c i) then Just (flip f i) else Nothing
231
232withNameFunc :: Maybe (Int -> Maybe a) -> FlattenM a () -> FlattenM a ()
233withNameFunc f@(Just _) = withReaderT (\e -> e { flattenNameFunc = f })
234withNameFunc Nothing = id
235
236withInlineStyle :: InlineStyle -> FlattenM a () -> FlattenM a ()
237withInlineStyle s =
238    withReaderT (\e -> e { flattenStyles = nub (s : flattenStyles e) })
239
240withHyperlink :: URL -> FlattenM a () -> FlattenM a ()
241withHyperlink u = withReaderT (\e -> e { flattenURL = Just u })
242
243-- | Push a FlattenedContent value onto the current line.
244pushFC :: SemEq a => FlattenedContent -> FlattenM a ()
245pushFC v = do
246    env <- ask
247    name <- getNextName
248    let styles = flattenStyles env
249        mUrl = flattenURL env
250        fi = FlattenedInline { fiValue = v
251                             , fiStyles = styles
252                             , fiURL = mUrl
253                             , fiName = name
254                             }
255    pushFV $ SingleInline fi
256
257getNextName :: FlattenM a (Maybe a)
258getNextName = do
259    nameGen <- asks flattenNameFunc
260    case nameGen of
261        Nothing -> return Nothing
262        Just f -> f <$> getNextNameIndex
263
264getNextNameIndex :: FlattenM a Int
265getNextNameIndex = do
266    c <- gets fsNameIndex
267    modify ( \s -> s { fsNameIndex = c + 1} )
268    return c
269
270setNextNameIndex :: Int -> FlattenM a ()
271setNextNameIndex i = modify ( \s -> s { fsNameIndex = i } )
272
273-- | Push a FlattenedValue onto the current line.
274pushFV :: SemEq a => FlattenedValue a -> FlattenM a ()
275pushFV fv = lift $ modify $ \s -> s { fsCurLine = appendFV fv (fsCurLine s) }
276
277-- | Append the value to the sequence.
278--
279-- If the both the value to append AND the sequence's last value are
280-- both text nodes, AND if those nodes both have the same style and URL
281-- metadata, then merge them into one text node. This keeps adjacent
282-- non-whitespace text together as one logical token (e.g. "(foo" rather
283-- than "(" followed by "foo") to avoid undesirable line break points in
284-- the wrapping process.
285appendFV :: SemEq a => FlattenedValue a -> Seq (FlattenedValue a) -> Seq (FlattenedValue a)
286appendFV v line =
287    case (Seq.viewr line, v) of
288        (h :> SingleInline a, SingleInline b) ->
289            case (fiValue a, fiValue b) of
290                (FText aT, FText bT) ->
291                    if fiStyles a == fiStyles b && fiURL a == fiURL b && fiName a `semeq` fiName b
292                    then h |> SingleInline (FlattenedInline (FText $ aT <> bT)
293                                                            (fiStyles a)
294                                                            (fiURL a)
295                                                            (max (fiName a) (fiName b)))
296                    else line |> v
297                _ -> line |> v
298        _ -> line |> v
299
300-- | Push the current line onto the finished lines list and start a new
301-- line.
302pushFLine :: FlattenM a ()
303pushFLine =
304    lift $ modify $ \s -> s { fsCompletedLines = fsCompletedLines s |> fsCurLine s
305                            , fsCurLine = mempty
306                            }
307
308isKnownUser :: T.Text -> FlattenM a Bool
309isKnownUser u = do
310    hSet <- asks flattenHighlightSet
311    let uSet = hUserSet hSet
312    return $ u `Set.member` uSet
313
314isKnownChannel :: T.Text -> FlattenM a Bool
315isKnownChannel c = do
316    hSet <- asks flattenHighlightSet
317    let cSet = hChannelSet hSet
318    return $ c `Set.member` cSet
319
320flatten :: SemEq a => Inline -> FlattenM a ()
321flatten i =
322    case i of
323        EUser u -> do
324            known <- isKnownUser u
325            if known then pushFC (FUser u)
326                     else pushFC (FText $ userSigil <> u)
327        EChannel c -> do
328            known <- isKnownChannel c
329            if known then pushFC (FChannel c)
330                     else pushFC (FText $ normalChannelSigil <> c)
331
332        ENonBreaking is -> do
333            env <- ask
334            ni <- getNextNameIndex
335            let (ni', s) = flattenInlineSeq' env ni is
336            pushFV $ NonBreaking s
337            setNextNameIndex ni'
338
339        ESoftBreak                  -> pushFLine
340        ELineBreak                  -> pushFLine
341
342        EText t                     -> pushFC $ FText t
343        ESpace                      -> pushFC FSpace
344        ERawHtml h                  -> pushFC $ FText h
345        EEmoji e                    -> pushFC $ FEmoji e
346        EEditSentinel r             -> pushFC $ FEditSentinel r
347
348        EEmph es                    -> withInlineStyle Emph $ flattenInlines es
349        EStrikethrough es           -> withInlineStyle Strikethrough $ flattenInlines es
350        EStrong es                  -> withInlineStyle Strong $ flattenInlines es
351        ECode es                    -> withInlineStyle Code $ flattenInlines es
352
353        EPermalink _ _ mLabel ->
354            let label' = fromMaybe (Inlines $ Seq.fromList [EText "post", ESpace, EText "link"])
355                                   mLabel
356            in withInlineStyle Permalink $ flattenInlines $ decorateLinkLabel label'
357
358        EHyperlink u label@(Inlines ls) ->
359            let label' = if Seq.null ls
360                         then Inlines $ Seq.singleton $ EText $ unURL u
361                         else label
362            in withHyperlink u $ flattenInlines $ decorateLinkLabel label'
363
364        EImage u label@(Inlines ls) ->
365            let label' = if Seq.null ls
366                         then Inlines $ Seq.singleton $ EText $ unURL u
367                         else label
368            in withHyperlink u $ flattenInlines $ decorateLinkLabel label'
369
370linkOpenBracket :: Inline
371linkOpenBracket = EText "<"
372
373linkCloseBracket :: Inline
374linkCloseBracket = EText ">"
375
376addOpenBracket :: Inlines -> Inlines
377addOpenBracket (Inlines l) =
378    case Seq.viewl l of
379        EmptyL -> Inlines l
380        h :< t ->
381            let h' = ENonBreaking $ Inlines $ Seq.fromList [linkOpenBracket, h]
382            in Inlines $ h' <| t
383
384addCloseBracket :: Inlines -> Inlines
385addCloseBracket (Inlines l) =
386    case Seq.viewr l of
387        EmptyR -> Inlines l
388        h :> t ->
389            let t' = ENonBreaking $ Inlines $ Seq.fromList [t, linkCloseBracket]
390            in Inlines $ h |> t'
391
392decorateLinkLabel :: Inlines -> Inlines
393decorateLinkLabel = addOpenBracket .  addCloseBracket
394