-- Copyright 2021 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

module Util.Html (
    Html(..), html, un_html
    -- ** create
    , tag, tag_class, link, tag_attrs
    , html_doc
    , HtmlState, get_html_state
) where
import qualified Data.Char as Char
import qualified Data.Set as Set
import qualified Data.String as String
import qualified Data.Text as Text
import           Data.Text (Text)

import qualified Util.Doc as Doc
import qualified Util.Files as Files
import qualified Util.Lists as Lists
import qualified Util.Pretty as Pretty
import qualified Util.Texts as Texts

import qualified App.Path as Path


newtype Html = Html Text
    deriving (NonEmpty Html -> Html
Html -> Html -> Html
forall b. Integral b => b -> Html -> Html
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Html -> Html
$cstimes :: forall b. Integral b => b -> Html -> Html
sconcat :: NonEmpty Html -> Html
$csconcat :: NonEmpty Html -> Html
<> :: Html -> Html -> Html
$c<> :: Html -> Html -> Html
Semigroup, Semigroup Html
Html
[Html] -> Html
Html -> Html -> Html
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Html] -> Html
$cmconcat :: [Html] -> Html
mappend :: Html -> Html -> Html
$cmappend :: Html -> Html -> Html
mempty :: Html
$cmempty :: Html
Monoid, String -> Html
forall a. (String -> a) -> IsString a
fromString :: String -> Html
$cfromString :: String -> Html
String.IsString, [Html] -> Doc
Html -> Text
Html -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Html] -> Doc
$cformatList :: [Html] -> Doc
format :: Html -> Doc
$cformat :: Html -> Doc
pretty :: Html -> Text
$cpretty :: Html -> Text
Pretty.Pretty, Int -> Html -> ShowS
[Html] -> ShowS
Html -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Html] -> ShowS
$cshowList :: [Html] -> ShowS
show :: Html -> String
$cshow :: Html -> String
showsPrec :: Int -> Html -> ShowS
$cshowsPrec :: Int -> Html -> ShowS
Show, Html -> Html -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Html -> Html -> Bool
$c/= :: Html -> Html -> Bool
== :: Html -> Html -> Bool
$c== :: Html -> Html -> Bool
Eq, Eq Html
Html -> Html -> Bool
Html -> Html -> Ordering
Html -> Html -> Html
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Html -> Html -> Html
$cmin :: Html -> Html -> Html
max :: Html -> Html -> Html
$cmax :: Html -> Html -> Html
>= :: Html -> Html -> Bool
$c>= :: Html -> Html -> Bool
> :: Html -> Html -> Bool
$c> :: Html -> Html -> Bool
<= :: Html -> Html -> Bool
$c<= :: Html -> Html -> Bool
< :: Html -> Html -> Bool
$c< :: Html -> Html -> Bool
compare :: Html -> Html -> Ordering
$ccompare :: Html -> Html -> Ordering
Ord)
    -- TODO doesn't IsString defeat the purpose of using Html in the first
    -- place?

instance Texts.Textlike Html where
    toText :: Html -> Text
toText (Html Text
t) = Text
t
    fromText :: Text -> Html
fromText = Text -> Html
Html

html :: Text -> Html
html :: Text -> Html
html = Text -> Html
Html forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
"<" Text
"&lt;" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
">" Text
"&gt;"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
"&" Text
"&amp;"

un_html :: Html -> Text
un_html :: Html -> Text
un_html (Html Text
text) = Text
text

-- ** create

tag :: Text -> Html -> Html
tag :: Text -> Html -> Html
tag Text
name Html
content = Text -> [(Text, Text)] -> Maybe Html -> Html
tag_attrs Text
name [] (forall a. a -> Maybe a
Just Html
content)

tag_class :: Text -> Text -> Html -> Html
tag_class :: Text -> Text -> Html -> Html
tag_class Text
name Text
class_ Html
content =
    Text -> [(Text, Text)] -> Maybe Html -> Html
tag_attrs Text
name [(Text
"class", Text
class_)] (forall a. a -> Maybe a
Just Html
content)

link :: Text -> Text -> Html
link :: Text -> Text -> Html
link Text
text Text
url = Text -> [(Text, Text)] -> Maybe Html -> Html
tag_attrs Text
"a" [(Text
"href", Text
url)] (forall a. a -> Maybe a
Just (Text -> Html
html Text
text))

tag_attrs :: Text -> [(Text, Text)] -> Maybe Html -> Html
tag_attrs :: Text -> [(Text, Text)] -> Maybe Html -> Html
tag_attrs Text
name [(Text, Text)]
attrs Maybe Html
mb_content = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
    Html
"<" forall a. a -> [a] -> [a]
: Text -> Html
html Text
name forall a. a -> [a] -> [a]
: Html
attrs_text forall a. a -> [a] -> [a]
: Html
">"
    forall a. a -> [a] -> [a]
: (case Maybe Html
mb_content of
        Maybe Html
Nothing -> []
        Just Html
content -> [Html
content, Html
"</", Text -> Html
html Text
name, Html
">"])
    where
    attrs_text :: Html
attrs_text
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Text)]
attrs = Html
""
        | Bool
otherwise = (Html
" "<>) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> [a] -> a
Lists.join Html
" "
            [ Text -> Html
html Text
name
                forall a. Semigroup a => a -> a -> a
<> if Text -> Bool
Text.null Text
val then Html
"" else Html
"=\"" forall a. Semigroup a => a -> a -> a
<> Text -> Html
html Text
val forall a. Semigroup a => a -> a -> a
<> Html
"\""
            | (Text
name, Text
val) <- [(Text, Text)]
attrs
            ]

-- | Format a Doc to HTML.  Interpret simple markdown-like formatting:
-- single quotes for a reference to function or module haddock, backticks
-- for \<code\>, and newline for \<br\>.
--
-- TODO maybe support leading - for \<ol\>.
html_doc :: HtmlState -> Doc.Doc -> Html
html_doc :: HtmlState -> Doc -> Html
html_doc (String
haddock_dir, Set String
files) (Doc.Doc Text
doc) =
    Text -> Html
Html forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
postproc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
un_html forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
html forall a b. (a -> b) -> a -> b
$ Text
doc
    where
    -- To keep the Text vs. Html type distinction I'd have to have [Either Text
    -- Html] and make mapDelimited return a list, and I couldn't use
    -- Text.replace.  It's doable, but would be more trouble than it's worth.
    postproc :: Text -> Text
postproc = Text -> Text
para forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
backticks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
single_quotes
    para :: Text -> Text
para = HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
"\n" Text
"\n<br>"
    backticks :: Text -> Text
backticks = Bool -> Char -> (Text -> Text) -> Text -> Text
Texts.mapDelimited Bool
True Char
'`'
        (\Text
t -> Text
"<code>" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"</code>")
    single_quotes :: Text -> Text
single_quotes = Bool -> Char -> (Text -> Text) -> Text -> Text
Texts.mapDelimited Bool
False Char
'\'' forall a b. (a -> b) -> a -> b
$ \Text
text ->
        case Set String -> String -> Text -> Maybe String
Texts.haddockUrl Set String
files String
haddock_dir Text
text of
            Maybe String
Nothing -> Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
text forall a. Semigroup a => a -> a -> a
<> Text
"'"
            Just String
url -> Html -> Text
un_html forall a b. (a -> b) -> a -> b
$ Text -> Text -> Html
link Text
text (String -> Text
Text.pack String
url)

-- | (haddock_dir, directory_tree)
type HtmlState = (FilePath, Set.Set FilePath)

get_html_state :: FilePath -> Path.AppDir -> IO HtmlState
get_html_state :: String -> AppDir -> IO HtmlState
get_html_state String
haddock_dir AppDir
app_dir = do
    Set String
files <- AppDir -> IO (Set String)
get_files AppDir
app_dir
    -- The eventual output is in build/doc.
    forall (m :: * -> *) a. Monad m => a -> m a
return (String
haddock_dir, Set String
files)
    where
    get_files :: AppDir -> IO (Set String)
get_files (Path.AppDir String
dir) = do
        [String]
files <- (String -> Bool) -> String -> IO [String]
Files.listRecursive (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Char -> Bool
Char.isUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head) String
dir
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [String]
files