CurryHtml.hs 7.69 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
2
3
{- |
    Module      :  $Header$
    Description :  Generating HTML documentation
4
5
    Copyright   :  (c) 2011 - 2016, Björn Peemöller
                       2016       , Jan Tikovsky
Björn Peemöller 's avatar
Björn Peemöller committed
6
7
8
9
10
11
12
13
14
    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
15
16
module Html.CurryHtml (source2html) where

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

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

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

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

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

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

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

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

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

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

135
escIdent :: QualIdent -> String
136
escIdent = htmlQuote . idName . unqualify
137

138
139
140
141
142
143
144
145
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
146

147
-- which code has which css class
148
-- @param code
149
-- @return css class of the code
150
code2class :: Code -> String
151
152
153
154
155
156
157
158
159
160
161
162
163
164
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"
165

166
167
168
169
170
171
addModuleLink :: ModuleIdent -> ModuleIdent -> String -> String
addModuleLink m m' str 
  = "<a href=\"" ++ makeRelativePath m m' ++ "\">" ++ str ++ "</a>"

addEntityLink :: ModuleIdent -> String -> QualIdent -> String
addEntityLink m str qid =
172
173
174
  "<a href=\"" ++ modPath ++ "#" ++ fragment  ++ "\">" ++ str ++ "</a>"
  where
  modPath       = maybe "" (makeRelativePath m) mmid
175
  fragment      = string2urlencoded (idName ident)
176
  (mmid, ident) = (qidModule qid, qidIdent qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
177

178
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
179
180
makeRelativePath cur new  | cur == new = ""
                          | otherwise  = htmlFile new
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
181

182
htmlFile :: ModuleIdent -> String
Jan Rasmus Tikovsky 's avatar
Jan Rasmus Tikovsky committed
183
htmlFile m = moduleName m ++ "_curry.html"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
184
185

isCall :: Code -> Bool
186
187
188
189
190
isCall (TypeCons   TypeExport _ _) = True
isCall (TypeCons   TypeImport _ _) = True
isCall (TypeCons   TypeRefer  _ _) = True
isCall (TypeCons   _          _ _) = False
isCall (Identifier _          _ _) = False
191
isCall c                       = not (isDecl c) && isJust (getQualIdent c)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
192
193

isDecl :: Code -> Bool
194
195
196
197
isDecl (DataCons ConsDeclare _ _) = True
isDecl (Function FuncDeclare _ _) = True
isDecl (TypeCons TypeDeclare _ _) = True
isDecl _                          = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
198
199
200

-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
201
string2urlencoded = escapeURIString isUnreserved
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
202
203
204
205

htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
206
207
208
209
210
211
212
213
214
215
216
217
  | 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