-- 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.File as File
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq
import qualified Util.Texts as Texts

import qualified App.Path as Path


newtype Html = Html Text
    deriving (NonEmpty Html -> Html
Html -> Html -> Html
(Html -> Html -> Html)
-> (NonEmpty Html -> Html)
-> (forall b. Integral b => b -> Html -> Html)
-> Semigroup 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
Semigroup Html
-> Html
-> (Html -> Html -> Html)
-> ([Html] -> Html)
-> Monoid 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
(String -> Html) -> IsString Html
forall a. (String -> a) -> IsString a
fromString :: String -> Html
$cfromString :: String -> Html
String.IsString, [Html] -> Doc
Html -> Text
Html -> Doc
(Html -> Text) -> (Html -> Doc) -> ([Html] -> Doc) -> Pretty Html
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
(Int -> Html -> ShowS)
-> (Html -> String) -> ([Html] -> ShowS) -> Show Html
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
(Html -> Html -> Bool) -> (Html -> Html -> Bool) -> Eq Html
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
Eq Html
-> (Html -> Html -> Ordering)
-> (Html -> Html -> Bool)
-> (Html -> Html -> Bool)
-> (Html -> Html -> Bool)
-> (Html -> Html -> Bool)
-> (Html -> Html -> Html)
-> (Html -> Html -> Html)
-> Ord 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 (Text -> Html) -> (Text -> Text) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
"<" Text
"&lt;" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
">" Text
"&gt;"
    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [] (Html -> Maybe Html
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_)] (Html -> Maybe Html
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)] (Html -> Maybe Html
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 = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$
    Html
"<" Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
: Text -> Html
html Text
name Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
: Html
attrs_text Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
: Html
">"
    Html -> [Html] -> [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
        | [(Text, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Text)]
attrs = Html
""
        | Bool
otherwise = (Html
" "<>) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> [Html] -> Html
forall a. Monoid a => a -> [a] -> a
Seq.join Html
" "
            [ Text -> Html
html Text
name
                Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> if Text -> Bool
Text.null Text
val then Html
"" else Html
"=\"" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Text -> Html
html Text
val Html -> Html -> Html
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 (Text -> Html) -> (Text -> Text) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
postproc (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
un_html (Html -> Text) -> (Text -> Html) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
html (Text -> Html) -> Text -> 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 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
backticks (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
single_quotes
    para :: Text -> Text
para = 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>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
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
'\'' ((Text -> Text) -> Text -> Text) -> (Text -> Text) -> Text -> Text
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
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
            Just String
url -> Html -> Text
un_html (Html -> Text) -> Html -> Text
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.
    HtmlState -> IO HtmlState
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]
File.listRecursive (Bool -> (Char -> Bool) -> Maybe Char -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Char -> Bool
Char.isUpper (Maybe Char -> Bool) -> (String -> Maybe Char) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Char
forall a. [a] -> Maybe a
Seq.head) String
dir
        Set String -> IO (Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set String -> IO (Set String)) -> Set String -> IO (Set String)
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
files