{-# LANGUAGE DeriveAnyClass #-}

module Emanote.Model.Title
  ( Title,

    -- * Title conversion
    fromRoute,
    fromInlines,
    toInlines,

    -- * Rendering a Title
    titleSplice,
    titleSpliceNoHtml,
    toPlain,
  )
where

import Commonmark.Extensions.WikiLink (plainify)
import Data.Aeson (ToJSON)
import Emanote.Route qualified as R
import Heist.Extra.Splices.Pandoc qualified as HP
import Heist.Interpreted qualified as HI
import Relude
import Text.Pandoc.Definition qualified as B
import Text.Pandoc.Walk qualified as W

data Title
  = TitlePlain Text
  | TitlePandoc [B.Inline]
  deriving stock (Int -> Title -> ShowS
[Title] -> ShowS
Title -> String
(Int -> Title -> ShowS)
-> (Title -> String) -> ([Title] -> ShowS) -> Show Title
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Title] -> ShowS
$cshowList :: [Title] -> ShowS
show :: Title -> String
$cshow :: Title -> String
showsPrec :: Int -> Title -> ShowS
$cshowsPrec :: Int -> Title -> ShowS
Show, (forall x. Title -> Rep Title x)
-> (forall x. Rep Title x -> Title) -> Generic Title
forall x. Rep Title x -> Title
forall x. Title -> Rep Title x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Title x -> Title
$cfrom :: forall x. Title -> Rep Title x
Generic)
  deriving anyclass ([Title] -> Encoding
[Title] -> Value
Title -> Encoding
Title -> Value
(Title -> Value)
-> (Title -> Encoding)
-> ([Title] -> Value)
-> ([Title] -> Encoding)
-> ToJSON Title
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Title] -> Encoding
$ctoEncodingList :: [Title] -> Encoding
toJSONList :: [Title] -> Value
$ctoJSONList :: [Title] -> Value
toEncoding :: Title -> Encoding
$ctoEncoding :: Title -> Encoding
toJSON :: Title -> Value
$ctoJSON :: Title -> Value
ToJSON)

instance Eq Title where
  == :: Title -> Title -> Bool
(==) =
    -- Use toPlain here, rather than toInlines, because the same text can have
    -- different inlines structure. For example, "Foo Bar" can be represented as
    --   [Str "Foo", Space, Str "Bar"],
    -- or as,
    --   [Str "Foo Bar"]
    (Text -> Text -> Bool) -> (Title -> Text) -> Title -> Title -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Title -> Text
toPlain

instance Ord Title where
  compare :: Title -> Title -> Ordering
compare =
    (Text -> Text -> Ordering)
-> (Title -> Text) -> Title -> Title -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Title -> Text
toPlain

instance Semigroup Title where
  TitlePlain Text
a <> :: Title -> Title -> Title
<> TitlePlain Text
b =
    Text -> Title
TitlePlain (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)
  Title
x <> Title
y =
    [Inline] -> Title
TitlePandoc ([Inline] -> Title) -> [Inline] -> Title
forall a b. (a -> b) -> a -> b
$ ([Inline] -> [Inline] -> [Inline])
-> (Title -> [Inline]) -> Title -> Title -> [Inline]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on [Inline] -> [Inline] -> [Inline]
forall a. Semigroup a => a -> a -> a
(<>) Title -> [Inline]
toInlines Title
x Title
y

instance IsString Title where
  fromString :: String -> Title
fromString = Text -> Title
TitlePlain (Text -> Title) -> (String -> Text) -> String -> Title
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText

fromRoute :: R.LMLRoute -> Title
fromRoute :: LMLRoute -> Title
fromRoute =
  Text -> Title
TitlePlain (Text -> Title) -> (LMLRoute -> Text) -> LMLRoute -> Title
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> Text)
-> LMLRoute -> Text
forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute forall {a} (ext :: FileType a). R @a ext -> Text
forall (lmlType :: LML).
HasExt @SourceExt ('LMLType lmlType) =>
R @SourceExt ('LMLType lmlType) -> Text
R.routeBaseName

fromInlines :: [B.Inline] -> Title
fromInlines :: [Inline] -> Title
fromInlines = [Inline] -> Title
TitlePandoc

toInlines :: Title -> [B.Inline]
toInlines :: Title -> [Inline]
toInlines = \case
  TitlePlain Text
s -> OneItem [Inline] -> [Inline]
forall x. One x => OneItem x -> x
one (Text -> Inline
B.Str Text
s)
  TitlePandoc [Inline]
is -> [Inline]
is

toPlain :: Title -> Text
toPlain :: Title -> Text
toPlain = \case
  TitlePlain Text
s -> Text
s
  TitlePandoc [Inline]
is -> [Inline] -> Text
plainify [Inline]
is

titleSplice ::
  forall b.
  (W.Walkable B.Inline b, b ~ [B.Inline]) =>
  HP.RenderCtx ->
  (b -> b) ->
  Title ->
  HI.Splice Identity
titleSplice :: forall b.
(Walkable Inline b, (b :: Type) ~ ([Inline] :: Type)) =>
RenderCtx -> (b -> b) -> Title -> Splice Identity
titleSplice RenderCtx
ctx b -> b
f = \case
  TitlePlain Text
x ->
    Text -> Splice Identity
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m Template
HI.textSplice Text
x
  TitlePandoc [Inline]
is -> do
    let titleDoc :: Pandoc
titleDoc = Meta -> [Block] -> Pandoc
B.Pandoc Meta
forall a. Monoid a => a
mempty ([Block] -> Pandoc) -> [Block] -> Pandoc
forall a b. (a -> b) -> a -> b
$ OneItem [Block] -> [Block]
forall x. One x => OneItem x -> x
one (OneItem [Block] -> [Block]) -> OneItem [Block] -> [Block]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Block
B.Plain ([Inline] -> Block) -> [Inline] -> Block
forall a b. (a -> b) -> a -> b
$ b -> b
f b
[Inline]
is
    RenderCtx -> Pandoc -> Splice Identity
HP.pandocSplice RenderCtx
ctx Pandoc
titleDoc

titleSpliceNoHtml :: Title -> HI.Splice Identity
titleSpliceNoHtml :: Title -> Splice Identity
titleSpliceNoHtml =
  Text -> Splice Identity
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m Template
HI.textSplice (Text -> Splice Identity)
-> (Title -> Text) -> Title -> Splice Identity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Title -> Text
toPlain