CurryHtml.hs 7.06 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
2
3
{- |
    Module      :  $Header$
    Description :  Generating HTML documentation
Björn Peemöller 's avatar
Björn Peemöller committed
4
    Copyright   :  (c) 2011 - 2014, 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
17
import Control.Monad.Writer

18
import Data.List             (mapAccumL)
19
import Data.Maybe            (fromMaybe, isJust)
20
21
import Network.URI           (escapeURIString, isUnreserved)
import System.FilePath       ((</>), dropFileName, joinPath, takeBaseName)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
22

23
import Curry.Base.Ident      (ModuleIdent (..), QualIdent (..), unqualify)
24
import Curry.Base.Monad
Björn Peemöller 's avatar
Björn Peemöller committed
25
import Curry.Base.Pretty     (text)
26
import Curry.Files.Filenames (moduleNameToFile)
27
import Curry.Files.PathUtils (readModule, lookupCurryFile)
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

Björn Peemöller 's avatar
Björn Peemöller committed
32
import Base.Messages
33
import CompilerOpts          (Options (..), WarnOpts (..))
Björn Peemöller 's avatar
Björn Peemöller committed
34
import CurryBuilder          (buildCurry)
35
36
import Modules               (loadAndCheckModule)
import Transformations       (qual)
37
38
39
40
import Paths_curry_frontend  (getDataFileName)

cssFile :: FilePath
cssFile = "currysource.css"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
41

42
43
-- translate source file into HTML file with syntaxcoloring
-- @param sourcefilename
Björn Peemöller 's avatar
Björn Peemöller committed
44
source2html :: Options -> FilePath -> CYIO ()
45
source2html opts f = do
46
47
48
  let baseName   = takeBaseName f
      outDir     = fromMaybe (dropFileName f) $ optHtmlDir opts
      outFile    = outDir </> baseName ++ "_curry.html"
49
  srcFile <- liftIO $ lookupCurryFile ("." : optImportPaths opts) f
50
51
  (m, program) <- filename2program opts (fromMaybe f srcFile)
  liftIO $ writeFile outFile (program2html m program)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
52

53
54
55
-- @param importpaths
-- @param filename
-- @return program
56
filename2program :: Options -> String -> CYIO (ModuleIdent, [Code])
57
filename2program opts f = do
Björn Peemöller 's avatar
Björn Peemöller committed
58
  mbModule <- liftIO $ readModule f
59
  case mbModule of
60
    Nothing  -> failMessages [message $ text $ "Missing file: " ++ f]
61
    Just src -> do
62
63
64
      toks  <- liftCYM $ lexSource f src
      typed@(Module _ m _ _ _) <- fullParse opts f src
      return (m, genProgram typed toks)
65
66
67
68
69
70
71
72

-- |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
73
fullParse opts fn _ = do
74
  buildCurry (opts { optTargetTypes = []}) fn
75
  (env, mdl) <- loadAndCheckModule opts' fn
76
  return (fst $ qual opts env mdl)
77
78
79
80
  where
  opts' = opts { optWarnOpts    = (optWarnOpts opts) { wnWarn = False }
               , optTargetTypes = []
               }
Björn Peemöller 's avatar
Björn Peemöller committed
81

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

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

121
122
123
escIdent :: QualIdent -> String
escIdent = htmlQuote . show . unqualify

124
125
126
127
128
129
130
131
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
132

133
-- which code has which css class
134
-- @param code
135
-- @return css class of the code
136
code2class :: Code -> String
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
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"
152

153
154
155
156
157
158
159
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
160

161
162
163
164
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
makeRelativePath cur new
  | cur == new = ""
  | otherwise  = makeTopPath cur </> moduleNameToFile new ++ "_curry.html"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
165

166
167
makeTopPath :: ModuleIdent -> String
makeTopPath m = joinPath $ replicate (length (midQualifiers m) - 1) ".."
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
168
169

isCall :: Code -> Bool
170
171
172
173
174
175
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
176
177

isDecl :: Code -> Bool
178
179
180
181
182
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
183
184
185

-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
186
string2urlencoded = escapeURIString isUnreserved
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
187
188
189
190

htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
191
192
193
194
195
196
197
198
199
200
201
202
  | 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