CurryHtml.hs 7.4 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)
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
import Curry.Base.Ident      (ModuleIdent (..), QualIdent (..), unqualify)
24
25
26
import Curry.Base.Monad      (CYIO, liftCYM, failMessages)
import Curry.Base.Pretty     ((<+>), text, vcat)
import Curry.Files.PathUtils (readModule)
27
import Curry.Syntax          (Module (..), lexSource)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
28

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

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

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

42
43
44
45
46
47
48
49
50
51
52
53
54
55
-- |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
  updateCSSFile opts outDir

-- |Update the CSS file
updateCSSFile :: Options -> FilePath -> CYIO ()
updateCSSFile opts dir = do
  src <- liftIO $ getDataFileName cssFile
56
  let target = dir </> cssFile
57
58
59
60
61
62
63
64
65
66
67
68
  srcExists <- liftIO $ doesFileExist src
  if srcExists then liftIO $ copyFile src target
               else warn (optWarnOpts opts) [message $ missingStyleFile src ]
  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
69
  mbModule <- liftIO $ readModule f
70
  case mbModule of
71
    Nothing  -> failMessages [message $ text $ "Missing file: " ++ f]
72
    Just src -> do
73
74
      toks  <- liftCYM $ lexSource f src
      typed@(Module _ m _ _ _) <- fullParse opts f src
75
      return (m, program2html m $ genProgram typed toks)
76
77
78
79
80
81
82
83

-- |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
84
fullParse opts fn _ = do
85
  buildCurry (opts { optTargetTypes = []}) fn
86
  (env, mdl) <- loadAndCheckModule opts' fn
87
  return (snd $ qual opts (env, mdl))
88
89
90
91
  where
  opts' = opts { optWarnOpts    = (optWarnOpts opts) { wnWarn = False }
               , optTargetTypes = []
               }
Björn Peemöller 's avatar
Björn Peemöller committed
92

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
93
94
95
96
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
97
98
program2html :: ModuleIdent -> [Code] -> String
program2html m codes = unlines
99
  [ "<!DOCTYPE html>"
100
101
102
  , "<html>", "<head>"
  , "<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />"
  , "<title>" ++ titleHtml ++ "</title>"
103
  , "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ cssFile ++ "\"/>"
104
  , "</head>"
105
  , "<body>"
106
107
108
109
110
111
112
113
  , "<table><tbody><tr>"
  , "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"
  , "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"
  , "</tr></tbody></table>"
  , "</body>"
  , "</html>"
  ]
  where
114
115
116
117
118
119
120
121
122
  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
123
        -> (i:defs, spanTag (code2class c) (escIdent i) (escCode c))
124
125
126
127
128
129
130
      _ -> (defs, tag)
  | otherwise = (defs, tag)
  where tag = spanTag (code2class c) "" (escCode c)

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

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

134
135
136
137
138
139
140
141
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
142

143
-- which code has which css class
144
-- @param code
145
-- @return css class of the code
146
code2class :: Code -> String
147
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 (Label      _ _) = "label"
code2class (Function   _ _) = "func"
code2class (Identifier _ _) = "ident"
code2class (ModuleName   _) = "module"
code2class (Commentary   _) = "comment"
code2class (NumberCode   _) = "number"
code2class (StringCode   _) = "string"
code2class (CharCode     _) = "char"
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
176
htmlFile :: ModuleIdent -> String
htmlFile m = show 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
191
isDecl (DataCons ConsDeclare  _) = True
isDecl (Function FuncDeclare  _) = True
isDecl (TypeCons TypeDeclare  _) = True
isDecl (Label    LabelDeclare _) = True
isDecl _                         = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
192
193
194

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

htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
200
201
202
203
204
205
206
207
208
209
210
211
  | 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