{-# 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 (..))
cssContent :: ByteString
cssContent :: ByteString
cssContent = $(makeRelativeToProject "data/currysource.css" >>= embedFile)
cssFileName :: String
cssFileName :: String
cssFileName = "currysource.css"
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)
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
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.0\">"
, "<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]
++ "\""
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
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
== '<' = "<" 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
== '>' = ">" 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
== '&' = "&" 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
== '"' = """ 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
== 'ä' = "ä" 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
== 'ö' = "ö" 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
== 'ü' = "ü" 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
== 'Ä' = "Ä" 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
== 'Ö' = "Ö" 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
== 'Ü' = "Ü" 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
== 'ß' = "ß" 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