CurryHtml.hs 7.33 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1 2 3
{- |
    Module      :  $Header$
    Description :  Generating HTML documentation
4
    Copyright   :  (c) 2011 - 2015, Björn Peemöller
Björn Peemöller 's avatar
Björn Peemöller committed
5 6 7 8 9 10 11 12 13
    License     :  OtherLicense

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

    This module defines a function for generating HTML documentation pages
    for Curry source modules.
-}
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
14 15
module Html.CurryHtml (source2html) where

Björn Peemöller 's avatar
Björn Peemöller committed
16
import Control.Monad.Writer
17
import Data.List             (mapAccumL)
Björn Peemöller 's avatar
Björn Peemöller committed
18
import Data.Maybe            (fromMaybe, isJust)
19
import Network.URI           (escapeURIString, isUnreserved)
20
import System.Directory      (copyFile, doesFileExist)
21
import System.FilePath       ((</>))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
22

23 24
import Curry.Base.Ident      ( ModuleIdent (..), QualIdent (..), unqualify
                             , moduleName)
25 26 27
import Curry.Base.Monad      (CYIO, liftCYM, failMessages)
import Curry.Base.Pretty     ((<+>), text, vcat)
import Curry.Files.PathUtils (readModule)
28
import Curry.Syntax          (Module (..), lexSource)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
29

Björn Peemöller 's avatar
Björn Peemöller committed
30 31
import Html.SyntaxColoring

32
import Base.Messages         (message)
33
import CompilerOpts          (Options (..), WarnOpts (..))
34
import CurryBuilder          (buildCurry, findCurry)
35 36
import Modules               (loadAndCheckModule)
import Transformations       (qual)
37 38
import Paths_curry_frontend  (getDataFileName)

39
-- |'FilePath' of the CSS style file to be added to the documentation.
40 41
cssFile :: FilePath
cssFile = "currysource.css"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
42

43 44 45 46 47 48 49 50
-- |Translate source file into HTML file with syntaxcoloring
source2html :: Options -> String -> CYIO ()
source2html opts s = do
  srcFile    <- findCurry opts s
  (mid, doc) <- docModule opts srcFile
  let outDir  = fromMaybe "." $ optHtmlDir opts
      outFile = outDir </> htmlFile mid
  liftIO $ writeFile outFile doc
51
  updateCSSFile outDir
52 53

-- |Update the CSS file
54 55
updateCSSFile :: FilePath -> CYIO ()
updateCSSFile dir = do
56
  src <- liftIO $ getDataFileName cssFile
57
  let target = dir </> cssFile
58 59
  srcExists <- liftIO $ doesFileExist src
  if srcExists then liftIO $ copyFile src target
60
               else failMessages [message $ missingStyleFile src]
61 62 63 64 65 66 67 68 69
  where
  missingStyleFile f = vcat
    [ text "Could not copy CSS style file:"
    , text "File" <+> text ("`" ++ f ++ "'") <+> text "does not exist"
    ]

-- |Create the documentation for the module
docModule :: Options -> String -> CYIO (ModuleIdent, String)
docModule opts f = do
Björn Peemöller 's avatar
Björn Peemöller committed
70
  mbModule <- liftIO $ readModule f
71
  case mbModule of
72
    Nothing  -> failMessages [message $ text $ "Missing file: " ++ f]
Björn Peemöller 's avatar
Björn Peemöller committed
73
    Just src -> do
74 75
      toks  <- liftCYM $ lexSource f src
      typed@(Module _ m _ _ _) <- fullParse opts f src
76
      return (m, program2html m $ genProgram f typed toks)
77 78 79 80 81 82 83 84

-- |Return the syntax tree of the source program 'src' (type 'Module'; see
-- Module "CurrySyntax").after inferring the types of identifiers.
-- 'fullParse' always searches for standard Curry libraries in the path
-- defined in the
-- environment variable "PAKCSLIBPATH". Additional search paths can
-- be defined using the argument 'paths'.
fullParse :: Options -> FilePath -> String -> CYIO Module
Björn Peemöller 's avatar
Björn Peemöller committed
85
fullParse opts fn _ = do
86
  buildCurry (opts { optTargetTypes = []}) fn
87
  (env, mdl) <- loadAndCheckModule opts' fn
88
  return (snd $ qual (env, mdl))
89 90 91 92
  where
  opts' = opts { optWarnOpts    = (optWarnOpts opts) { wnWarn = False }
               , optTargetTypes = []
               }
Björn Peemöller 's avatar
Björn Peemöller committed
93

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
94 95 96 97
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
98 99
program2html :: ModuleIdent -> [Code] -> String
program2html m codes = unlines
100
  [ "<!DOCTYPE html>"
101 102 103
  , "<html>", "<head>"
  , "<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />"
  , "<title>" ++ titleHtml ++ "</title>"
104
  , "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ cssFile ++ "\"/>"
105
  , "</head>"
106
  , "<body>"
107 108 109 110 111 112 113 114
  , "<table><tbody><tr>"
  , "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"
  , "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"
  , "</tr></tbody></table>"
  , "</body>"
  , "</html>"
  ]
  where
115 116 117 118 119 120 121 122 123
  titleHtml = "Module " ++ show m
  lineHtml  = unlines $ map show [1 .. length (lines codeHtml)]
  codeHtml  = concat $ snd $ mapAccumL (code2html m) [] codes

code2html :: ModuleIdent -> [QualIdent] -> Code -> ([QualIdent], String)
code2html m defs c
  | isCall c  = (defs, maybe tag (addHtmlLink m tag) (getQualIdent c))
  | isDecl c  = case getQualIdent c of
      Just i | i `notElem` defs
124
        -> (i:defs, spanTag (code2class c) (escIdent i) (escCode c))
125 126 127 128 129 130 131
      _ -> (defs, tag)
  | otherwise = (defs, tag)
  where tag = spanTag (code2class c) "" (escCode c)

escCode :: Code -> String
escCode = htmlQuote . code2string

132 133 134
escIdent :: QualIdent -> String
escIdent = htmlQuote . show . unqualify

135 136 137 138 139 140 141 142
spanTag :: String -> String -> String -> String
spanTag clV idV str
  | null clV && null idV = str
  | otherwise            = "<span" ++ codeclass ++ idValue ++ ">"
                           ++ str ++ "</span>"
  where
  codeclass = if null clV then "" else " class=\"" ++ clV ++ "\""
  idValue   = if null idV then "" else " id=\"" ++ idV ++ "\""
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
143

144
-- which code has which css class
Björn Peemöller 's avatar
Björn Peemöller committed
145
-- @param code
146
-- @return css class of the code
Björn Peemöller 's avatar
Björn Peemöller committed
147
code2class :: Code -> String
148 149 150 151 152 153 154 155 156 157 158 159 160 161
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"
Björn Peemöller 's avatar
Björn Peemöller committed
162

163 164 165 166 167 168 169
addHtmlLink :: ModuleIdent -> String -> QualIdent -> String
addHtmlLink m str qid =
  "<a href=\"" ++ modPath ++ "#" ++ fragment  ++ "\">" ++ str ++ "</a>"
  where
  modPath       = maybe "" (makeRelativePath m) mmid
  fragment      = string2urlencoded (show ident)
  (mmid, ident) = (qidModule qid, qidIdent qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
170

171
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
172 173
makeRelativePath cur new  | cur == new = ""
                          | otherwise  = htmlFile new
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
174

175
htmlFile :: ModuleIdent -> String
Jan Rasmus Tikovsky 's avatar
Jan Rasmus Tikovsky committed
176
htmlFile m = moduleName m ++ "_curry.html"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
177 178

isCall :: Code -> Bool
179 180 181 182 183 184
isCall (TypeCons TypeExport _) = True
isCall (TypeCons TypeImport _) = True
isCall (TypeCons TypeRefer  _) = True
isCall (TypeCons          _ _) = False
isCall (Identifier        _ _) = False
isCall c                       = not (isDecl c) && isJust (getQualIdent c)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
185 186

isDecl :: Code -> Bool
187 188 189 190
isDecl (DataCons ConsDeclare  _) = True
isDecl (Function FuncDeclare  _) = True
isDecl (TypeCons TypeDeclare  _) = True
isDecl _                         = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
191 192 193

-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
194
string2urlencoded = escapeURIString isUnreserved
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
195 196 197 198

htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
199 200 201 202 203 204 205 206 207 208 209 210
  | c == '<'  = "&lt;"    ++ htmlQuote cs
  | c == '>'  = "&gt;"    ++ htmlQuote cs
  | c == '&'  = "&amp;"   ++ htmlQuote cs
  | c == '"'  = "&quot;"  ++ htmlQuote cs
  | c == 'ä'  = "&auml;"  ++ htmlQuote cs
  | c == 'ö'  = "&ouml;"  ++ htmlQuote cs
  | c == 'ü'  = "&uuml;"  ++ htmlQuote cs
  | c == 'Ä'  = "&Auml;"  ++ htmlQuote cs
  | c == 'Ö'  = "&Ouml;"  ++ htmlQuote cs
  | c == 'Ü'  = "&Uuml;"  ++ htmlQuote cs
  | c == 'ß'  = "&szlig;" ++ htmlQuote cs
  | otherwise = c : htmlQuote cs