Flatten.hs

-- | This module implements a "flattening" pass over RichText 'Inline'
-- values. This means that a tree structure such as
--
-- @
--   EStrong
--     [ EStrikethrough
--       [ EText "inside"
--       ]
--     , EText "outside"
--     ]
-- @
--
-- will be converted into a "flat" representation without a tree
-- structure so that the style information encoded in the tree is
-- available at each node:
--
-- @
--   [
--     [ SingleInline (FlattenedInline (FText "inside") [Strong, Strikethrough] Nothing
--     , SingleInline (FlattenedInline (FText "outside") [Strong] Nothing
--     ]
--   ]
-- @
--
-- The outer sequence is a sequence of lines (since inline lists can
-- introduce line breaks). Each inner sequence is a single line.
-- Each 'SingleInline' can be rendered as-is; if a 'NonBreaking' is
-- encountered, that group of inlines should be treated as a unit for
-- the purposes of line-wrapping (to happen in the Wrap module). The
-- above representation example shows how the tree path including the
-- 'EStrong' and 'EStrikethrough' nodes is flattened into a list of
-- styles to accompany each inline value. This makes it trivial to carry
-- that style information along with each node during line-wrapping
-- rather than needing to deal with the tree structure.
module Matterhorn.Draw.RichText.Flatten
  ( FlattenedContent(..)
  , FlattenedInline(..)
  , InlineStyle(..)
  , FlattenedValue(..)
  , flattenInlineSeq
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Control.Monad.Reader
import           Control.Monad.State
import           Data.List ( nub )
import qualified Data.Sequence as Seq
import           Data.Sequence ( ViewL(..)
                               , ViewR(..)
                               , (<|)
                               , (|>)
                               )
import qualified Data.Set as Set
import qualified Data.Text as T

import           Matterhorn.Constants ( normalChannelSigil, userSigil )
import           Matterhorn.Types ( HighlightSet(..), SemEq(..) )
import           Matterhorn.Types.RichText


-- | A piece of text in a sequence of flattened RichText elements. This
-- type represents the lowest-level kind of data that we can get from a
-- rich text document.
data FlattenedContent =
    FText Text
    -- ^ Some text
    | FSpace
    -- ^ A space
    | FUser Text
    -- ^ A user reference
    | FChannel Text
    -- ^ A channel reference
    | FEmoji Text
    -- ^ An emoji
    | FEditSentinel Bool
    -- ^ An "edited" marking
    deriving (Eq, Show)

-- | A flattened inline value.
data FlattenedInline a =
    FlattenedInline { fiValue :: FlattenedContent
                    -- ^ The content of the value.
                    , fiStyles :: [InlineStyle]
                    -- ^ The styles that should be applied to this
                    -- value.
                    , fiURL :: Maybe URL
                    -- ^ If present, the URL to which we should
                    -- hyperlink this value.
                    , fiName :: Maybe a
                    -- ^ The resource name, if any, that should be used
                    -- to make this inline clickable once rendered.
                    }
                    deriving (Show)

-- | A flattened value.
data FlattenedValue a =
    SingleInline (FlattenedInline a)
    -- ^ A single flattened value
    | NonBreaking (Seq (Seq (FlattenedValue a)))
    -- ^ A sequence of flattened values that MUST be kept together and
    -- never broken up by line-wrapping
    deriving (Show)

-- | The visual styles of inline values.
data InlineStyle =
    Strong
    | Emph
    | Strikethrough
    | Code
    | Permalink
    deriving (Eq, Show)

type FlattenM n a = ReaderT (FlattenEnv n) (State (FlattenState n)) a

-- | The flatten monad state
data FlattenState a =
    FlattenState { fsCompletedLines :: Seq (Seq (FlattenedValue a))
                 -- ^ The lines that we have accumulated so far in the
                 -- flattening process
                 , fsCurLine :: Seq (FlattenedValue a)
                 -- ^ The current line we are accumulating in the
                 -- flattening process
                 , fsNameIndex :: Int
                 -- ^ The index used to generate a new unique name (of
                 -- type 'a') to make a region of text clickable.
                 }

-- | The flatten monad environment
data FlattenEnv a =
    FlattenEnv { flattenStyles :: [InlineStyle]
               -- ^ The styles that should apply to the current value
               -- being flattened
               , flattenURL :: Maybe URL
               -- ^ The hyperlink URL, if any, that should be applied to
               -- the current value being flattened
               , flattenHighlightSet :: HighlightSet
               -- ^ The highlight set to use to check for valid user or
               -- channel references
               , flattenNameGen :: Maybe (Int -> Inline -> Maybe a)
               -- ^ The function to use to generate resource names
               -- for clickable inlines. If provided, this is used to
               -- determine whether a given Inline should be augmented
               -- with a resource name.
               , flattenNameFunc :: Maybe (Int -> Maybe a)
               -- ^ The currently active function to generate a resource
               -- name for any inline. In practice this is just the
               -- value of flattenNameGen, but partially applied with a
               -- specific Inline prior to flattening that Inline.
               }

-- | Given a sequence of inlines, flatten it into a list of lines of
-- flattened values.
--
-- The flattening process also validates user and channel references
-- against a 'HighlightSet'. For example, if an 'EUser' node is found,
-- its username argument is looked up in the 'HighlightSet'. If the
-- username is found, the 'EUser' node is preserved as an 'FUser' node.
-- Otherwise it is rewritten as an 'FText' node so that the username
-- does not get highlighted. Channel references ('EChannel') are handled
-- similarly.
--
-- The optional name generator function argument is used to assign
-- resource names to each inline that should be clickable once rendered.
-- The result of the name generator function will be stored in the
-- 'fiName' field of each 'FlattenedInline' that results from calling
-- that function on an 'Inline'.
flattenInlineSeq :: SemEq a
                 => HighlightSet
                 -> Maybe (Int -> Inline -> Maybe a)
                 -- ^ A name generator function for clickable inlines.
                 -- The integer argument is a unique (to this inline
                 -- sequence) sequence number.
                 -> Inlines
                 -> Seq (Seq (FlattenedValue a))
flattenInlineSeq hs nameGen is =
    snd $ flattenInlineSeq' initialEnv 0 is
    where
        initialEnv = FlattenEnv { flattenStyles = []
                                , flattenURL = Nothing
                                , flattenHighlightSet = hs
                                , flattenNameGen = nameGen
                                , flattenNameFunc = Nothing
                                }

flattenInlineSeq' :: SemEq a
                  => FlattenEnv a
                  -> Int
                  -> Inlines
                  -> (Int, Seq (Seq (FlattenedValue a)))
flattenInlineSeq' env c is =
    (fsNameIndex finalState, fsCompletedLines finalState)
    where
        finalState = execState stBody initialState
        initialState = FlattenState { fsCompletedLines = mempty
                                    , fsCurLine = mempty
                                    , fsNameIndex = c
                                    }
        stBody = runReaderT body env
        body = do
            flattenInlines is
            pushFLine

flattenInlines :: SemEq a => Inlines -> FlattenM a ()
flattenInlines is = do
    pairs <- nameInlinePairs
    mapM_ wrapFlatten pairs
    where
        wrapFlatten (nameFunc, i) = withNameFunc nameFunc $ flatten i

        -- For each inline, prior to flattening it, obtain the resource
        -- name (if any) that should be assigned to each flattened
        -- fragment of the inline.
        nameInlinePairs = forM (unInlines is) $ \i -> do
            nameFunc <- nameGenWrapper i
            return (nameFunc, i)

        -- Determine whether the name generation function will produce
        -- a name for this inline. If it does (using a fake sequence
        -- number) then return a new name generation function to use for
        -- all flattened fragments of this inline.
        nameGenWrapper :: Inline -> FlattenM a (Maybe (Int -> Maybe a))
        nameGenWrapper i = do
            c <- gets fsNameIndex
            nameGen <- asks flattenNameGen
            return $ case nameGen of
                Nothing -> Nothing
                Just f -> if isJust (f c i) then Just (flip f i) else Nothing

withNameFunc :: Maybe (Int -> Maybe a) -> FlattenM a () -> FlattenM a ()
withNameFunc f@(Just _) = withReaderT (\e -> e { flattenNameFunc = f })
withNameFunc Nothing = id

withInlineStyle :: InlineStyle -> FlattenM a () -> FlattenM a ()
withInlineStyle s =
    withReaderT (\e -> e { flattenStyles = nub (s : flattenStyles e) })

withHyperlink :: URL -> FlattenM a () -> FlattenM a ()
withHyperlink u = withReaderT (\e -> e { flattenURL = Just u })

-- | Push a FlattenedContent value onto the current line.
pushFC :: SemEq a => FlattenedContent -> FlattenM a ()
pushFC v = do
    env <- ask
    name <- getNextName
    let styles = flattenStyles env
        mUrl = flattenURL env
        fi = FlattenedInline { fiValue = v
                             , fiStyles = styles
                             , fiURL = mUrl
                             , fiName = name
                             }
    pushFV $ SingleInline fi

getNextName :: FlattenM a (Maybe a)
getNextName = do
    nameGen <- asks flattenNameFunc
    case nameGen of
        Nothing -> return Nothing
        Just f -> f <$> getNextNameIndex

getNextNameIndex :: FlattenM a Int
getNextNameIndex = do
    c <- gets fsNameIndex
    modify ( \s -> s { fsNameIndex = c + 1} )
    return c

setNextNameIndex :: Int -> FlattenM a ()
setNextNameIndex i = modify ( \s -> s { fsNameIndex = i } )

-- | Push a FlattenedValue onto the current line.
pushFV :: SemEq a => FlattenedValue a -> FlattenM a ()
pushFV fv = lift $ modify $ \s -> s { fsCurLine = appendFV fv (fsCurLine s) }

-- | Append the value to the sequence.
--
-- If the both the value to append AND the sequence's last value are
-- both text nodes, AND if those nodes both have the same style and URL
-- metadata, then merge them into one text node. This keeps adjacent
-- non-whitespace text together as one logical token (e.g. "(foo" rather
-- than "(" followed by "foo") to avoid undesirable line break points in
-- the wrapping process.
appendFV :: SemEq a => FlattenedValue a -> Seq (FlattenedValue a) -> Seq (FlattenedValue a)
appendFV v line =
    case (Seq.viewr line, v) of
        (h :> SingleInline a, SingleInline b) ->
            case (fiValue a, fiValue b) of
                (FText aT, FText bT) ->
                    if fiStyles a == fiStyles b && fiURL a == fiURL b && fiName a `semeq` fiName b
                    then h |> SingleInline (FlattenedInline (FText $ aT <> bT)
                                                            (fiStyles a)
                                                            (fiURL a)
                                                            (max (fiName a) (fiName b)))
                    else line |> v
                _ -> line |> v
        _ -> line |> v

-- | Push the current line onto the finished lines list and start a new
-- line.
pushFLine :: FlattenM a ()
pushFLine =
    lift $ modify $ \s -> s { fsCompletedLines = fsCompletedLines s |> fsCurLine s
                            , fsCurLine = mempty
                            }

isKnownUser :: T.Text -> FlattenM a Bool
isKnownUser u = do
    hSet <- asks flattenHighlightSet
    let uSet = hUserSet hSet
    return $ u `Set.member` uSet

isKnownChannel :: T.Text -> FlattenM a Bool
isKnownChannel c = do
    hSet <- asks flattenHighlightSet
    let cSet = hChannelSet hSet
    return $ c `Set.member` cSet

flatten :: SemEq a => Inline -> FlattenM a ()
flatten i =
    case i of
        EUser u -> do
            known <- isKnownUser u
            if known then pushFC (FUser u)
                     else pushFC (FText $ userSigil <> u)
        EChannel c -> do
            known <- isKnownChannel c
            if known then pushFC (FChannel c)
                     else pushFC (FText $ normalChannelSigil <> c)

        ENonBreaking is -> do
            env <- ask
            ni <- getNextNameIndex
            let (ni', s) = flattenInlineSeq' env ni is
            pushFV $ NonBreaking s
            setNextNameIndex ni'

        ESoftBreak                  -> pushFLine
        ELineBreak                  -> pushFLine

        EText t                     -> pushFC $ FText t
        ESpace                      -> pushFC FSpace
        ERawHtml h                  -> pushFC $ FText h
        EEmoji e                    -> pushFC $ FEmoji e
        EEditSentinel r             -> pushFC $ FEditSentinel r

        EEmph es                    -> withInlineStyle Emph $ flattenInlines es
        EStrikethrough es           -> withInlineStyle Strikethrough $ flattenInlines es
        EStrong es                  -> withInlineStyle Strong $ flattenInlines es
        ECode es                    -> withInlineStyle Code $ flattenInlines es

        EPermalink _ _ mLabel ->
            let label' = fromMaybe (Inlines $ Seq.fromList [EText "post", ESpace, EText "link"])
                                   mLabel
            in withInlineStyle Permalink $ flattenInlines $ decorateLinkLabel label'

        EHyperlink u label@(Inlines ls) ->
            let label' = if Seq.null ls
                         then Inlines $ Seq.singleton $ EText $ unURL u
                         else label
            in withHyperlink u $ flattenInlines $ decorateLinkLabel label'

        EImage u label@(Inlines ls) ->
            let label' = if Seq.null ls
                         then Inlines $ Seq.singleton $ EText $ unURL u
                         else label
            in withHyperlink u $ flattenInlines $ decorateLinkLabel label'

linkOpenBracket :: Inline
linkOpenBracket = EText "<"

linkCloseBracket :: Inline
linkCloseBracket = EText ">"

addOpenBracket :: Inlines -> Inlines
addOpenBracket (Inlines l) =
    case Seq.viewl l of
        EmptyL -> Inlines l
        h :< t ->
            let h' = ENonBreaking $ Inlines $ Seq.fromList [linkOpenBracket, h]
            in Inlines $ h' <| t

addCloseBracket :: Inlines -> Inlines
addCloseBracket (Inlines l) =
    case Seq.viewr l of
        EmptyR -> Inlines l
        h :> t ->
            let t' = ENonBreaking $ Inlines $ Seq.fromList [t, linkCloseBracket]
            in Inlines $ h |> t'

decorateLinkLabel :: Inlines -> Inlines
decorateLinkLabel = addOpenBracket .  addCloseBracket