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