{- |
    Module      :  $Header$
    Description :  Generating HTML documentation
    Copyright   :  (c) 2011 - 2016, Björn Peemöller
                       2016       , Jan Tikovsky
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module defines a function for generating HTML documentation pages
    for Curry source modules.
-}
{-# LANGUAGE TemplateHaskell   #-}
module Html.CurryHtml (source2html) where

import Prelude         as P
import Control.Monad.Writer
import Data.List             (mapAccumL)
import Data.Maybe            (fromMaybe, isJust)
import Data.ByteString as BS (ByteString, writeFile)
import Data.FileEmbed
import Network.URI           (escapeURIString, isUnreserved)
import System.FilePath       ((</>))

import Curry.Base.Ident      ( ModuleIdent (..), Ident (..), QualIdent (..)
                             , unqualify, moduleName)
import Curry.Base.Monad      (CYIO)
import Curry.Base.Position   (Position)
import Curry.Files.Filenames (htmlName)
import Curry.Syntax          (Module (..), Token)

import Html.SyntaxColoring


import CompilerOpts          (Options (..))

-- |Read file via TemplateHaskell at compile time
cssContent :: ByteString
cssContent :: ByteString
cssContent = $(makeRelativeToProject "data/currysource.css" >>= embedFile)

-- | Name of the css file
-- NOTE: The relative path is given above
cssFileName :: String
cssFileName :: String
cssFileName = "currysource.css"

-- |Translate source file into HTML file with syntaxcoloring
source2html :: Options -> ModuleIdent -> [(Position, Token)] -> Module a
            -> CYIO ()
source2html :: Options
-> ModuleIdent -> [(Position, Token)] -> Module a -> CYIO ()
source2html opts :: Options
opts mid :: ModuleIdent
mid toks :: [(Position, Token)]
toks mdl :: Module a
mdl = do
  IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
P.writeFile (String
outDir String -> String -> String
</> ModuleIdent -> String
htmlName ModuleIdent
mid) String
doc
  String -> CYIO ()
updateCSSFile String
outDir
  where
  doc :: String
doc    = ModuleIdent -> [Code] -> String
program2html ModuleIdent
mid (Module a -> [(Position, Token)] -> [Code]
forall a. Module a -> [(Position, Token)] -> [Code]
genProgram Module a
mdl [(Position, Token)]
toks)
  outDir :: String
outDir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "." (Options -> Maybe String
optHtmlDir Options
opts)

-- |Update the CSS file
updateCSSFile :: FilePath -> CYIO ()
updateCSSFile :: String -> CYIO ()
updateCSSFile dir :: String
dir = do
  let target :: String
target = String
dir String -> String -> String
</> String
cssFileName
  IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
target ByteString
cssContent

-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
program2html :: ModuleIdent -> [Code] -> String
program2html :: ModuleIdent -> [Code] -> String
program2html m :: ModuleIdent
m codes :: [Code]
codes = [String] -> String
unlines
  [ "<!DOCTYPE html>"
  , "<html lang=\"en\">"
  , "<head>"
  , "<meta charset=\"utf-8\" />"
  , "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\" />"
  , "<title>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
titleHtml String -> String -> String
forall a. [a] -> [a] -> [a]
++ "</title>"
  , "<link rel=\"stylesheet\" href=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cssFileName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\" />"
  , "</head>"
  , "<body>"
  , "<table><tbody><tr>"
  , "<td class=\"line-numbers\"><pre>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lineHtml String -> String -> String
forall a. [a] -> [a] -> [a]
++ "</pre></td>"
  , "<td class=\"source-code\"><pre>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
codeHtml String -> String -> String
forall a. [a] -> [a] -> [a]
++ "</pre></td>"
  , "</tr></tbody></table>"
  , "</body>"
  , "</html>"
  ]
  where
  titleHtml :: String
titleHtml = "Module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleIdent -> String
moduleName ModuleIdent
m
  lineHtml :: String
lineHtml  = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [1 .. [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> [String]
lines String
codeHtml)]
  codeHtml :: String
codeHtml  = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([QualIdent], [String]) -> [String]
forall a b. (a, b) -> b
snd (([QualIdent], [String]) -> [String])
-> ([QualIdent], [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ ([QualIdent] -> Code -> ([QualIdent], String))
-> [QualIdent] -> [Code] -> ([QualIdent], [String])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (ModuleIdent -> [QualIdent] -> Code -> ([QualIdent], String)
code2html ModuleIdent
m) [] [Code]
codes

code2html :: ModuleIdent -> [QualIdent] -> Code -> ([QualIdent], String)
code2html :: ModuleIdent -> [QualIdent] -> Code -> ([QualIdent], String)
code2html m :: ModuleIdent
m defs :: [QualIdent]
defs c :: Code
c
  | Code -> Bool
isCall Code
c  = ([QualIdent]
defs, String -> (QualIdent -> String) -> Maybe QualIdent -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
tag (ModuleIdent -> String -> QualIdent -> String
addEntityLink ModuleIdent
m String
tag) (Code -> Maybe QualIdent
getQualIdent Code
c))
  | Code -> Bool
isDecl Code
c  = case Code -> Maybe QualIdent
getQualIdent Code
c of
      Just i :: QualIdent
i | QualIdent
i QualIdent -> [QualIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [QualIdent]
defs
        -> (QualIdent
iQualIdent -> [QualIdent] -> [QualIdent]
forall a. a -> [a] -> [a]
:[QualIdent]
defs, String -> String -> String -> String
spanTag (Code -> String
code2class Code
c) (QualIdent -> String
escIdent QualIdent
i) (Code -> String
escCode Code
c))
      _ -> ([QualIdent]
defs, String
tag)
  | Bool
otherwise = case Code
c of
      ModuleName m' :: ModuleIdent
m' -> ([QualIdent]
defs, ModuleIdent -> ModuleIdent -> String -> String
addModuleLink ModuleIdent
m ModuleIdent
m' String
tag)
      _             -> ([QualIdent]
defs, String
tag)
  where tag :: String
tag = String -> String -> String -> String
spanTag (Code -> String
code2class Code
c) "" (Code -> String
escCode Code
c)

escCode :: Code -> String
escCode :: Code -> String
escCode = String -> String
htmlQuote (String -> String) -> (Code -> String) -> Code -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code -> String
code2string

escIdent :: QualIdent -> String
escIdent :: QualIdent -> String
escIdent = String -> String
htmlQuote (String -> String) -> (QualIdent -> String) -> QualIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
idName (Ident -> String) -> (QualIdent -> Ident) -> QualIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Ident
unqualify

spanTag :: String -> String -> String -> String
spanTag :: String -> String -> String -> String
spanTag clV :: String
clV idV :: String
idV str :: String
str
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
clV Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
idV = String
str
  | Bool
otherwise            = "<span" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
codeclass String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
idValue String -> String -> String
forall a. [a] -> [a] -> [a]
++ ">"
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "</span>"
  where
  codeclass :: String
codeclass = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
clV then "" else " class=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
clV String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\""
  idValue :: String
idValue   = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
idV then "" else " id=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
idV String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\""

-- which code has which css class
-- @param code
-- @return css class of the code
code2class :: Code -> String
code2class :: Code -> String
code2class (Space          _) = ""
code2class NewLine            = ""
code2class (Keyword        _) = "keyword"
code2class (Pragma         _) = "pragma"
code2class (Symbol         _) = "symbol"
code2class (TypeCons   _ _ _) = "type"
code2class (DataCons   _ _ _) = "cons"
code2class (Function   _ _ _) = "func"
code2class (Identifier _ _ _) = "ident"
code2class (ModuleName     _) = "module"
code2class (Commentary     _) = "comment"
code2class (NumberCode     _) = "number"
code2class (StringCode     _) = "string"
code2class (CharCode       _) = "char"

addModuleLink :: ModuleIdent -> ModuleIdent -> String -> String
addModuleLink :: ModuleIdent -> ModuleIdent -> String -> String
addModuleLink m :: ModuleIdent
m m' :: ModuleIdent
m' str :: String
str
  = "<a href=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleIdent -> ModuleIdent -> String
makeRelativePath ModuleIdent
m ModuleIdent
m' String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\">" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "</a>"

addEntityLink :: ModuleIdent -> String -> QualIdent -> String
addEntityLink :: ModuleIdent -> String -> QualIdent -> String
addEntityLink m :: ModuleIdent
m str :: String
str qid :: QualIdent
qid =
  "<a href=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ "#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fragment  String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\">" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "</a>"
  where
  modPath :: String
modPath       = String -> (ModuleIdent -> String) -> Maybe ModuleIdent -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (ModuleIdent -> ModuleIdent -> String
makeRelativePath ModuleIdent
m) Maybe ModuleIdent
mmid
  fragment :: String
fragment      = String -> String
string2urlencoded (Ident -> String
idName Ident
ident)
  (mmid :: Maybe ModuleIdent
mmid, ident :: Ident
ident) = (QualIdent -> Maybe ModuleIdent
qidModule QualIdent
qid, QualIdent -> Ident
qidIdent QualIdent
qid)

makeRelativePath :: ModuleIdent -> ModuleIdent -> String
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
makeRelativePath cur :: ModuleIdent
cur new :: ModuleIdent
new  | ModuleIdent
cur ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent
new = ""
                          | Bool
otherwise  = ModuleIdent -> String
htmlName ModuleIdent
new

isCall :: Code -> Bool
isCall :: Code -> Bool
isCall (TypeCons   TypeExport _ _) = Bool
True
isCall (TypeCons   TypeImport _ _) = Bool
True
isCall (TypeCons   TypeRefer  _ _) = Bool
True
isCall (TypeCons   _          _ _) = Bool
False
isCall (Identifier _          _ _) = Bool
False
isCall c :: Code
c                       = Bool -> Bool
not (Code -> Bool
isDecl Code
c) Bool -> Bool -> Bool
&& Maybe QualIdent -> Bool
forall a. Maybe a -> Bool
isJust (Code -> Maybe QualIdent
getQualIdent Code
c)

isDecl :: Code -> Bool
isDecl :: Code -> Bool
isDecl (DataCons ConsDeclare _ _) = Bool
True
isDecl (Function FuncDeclare _ _) = Bool
True
isDecl (TypeCons TypeDeclare _ _) = Bool
True
isDecl _                          = Bool
False

-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
string2urlencoded :: String -> String
string2urlencoded = (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isUnreserved

htmlQuote :: String -> String
htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c :: Char
c : cs :: String
cs)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '<'  = "&lt;"    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '>'  = "&gt;"    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '&'  = "&amp;"   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '"'  = "&quot;"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'ä'  = "&auml;"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'ö'  = "&ouml;"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'ü'  = "&uuml;"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Ä'  = "&Auml;"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Ö'  = "&Ouml;"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Ü'  = "&Uuml;"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'ß'  = "&szlig;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
htmlQuote String
cs
  | Bool
otherwise = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
htmlQuote String
cs