CurryHtml.hs 7.59 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.
-}
14
{-# LANGUAGE CPP #-}
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
15
16
module Html.CurryHtml (source2html) where

17
18
19
#if __GLASGOW_HASKELL__ >= 710
import Control.Applicative   ((<$>))
#else
20
import Control.Applicative   ((<$>), (<*>))
21
#endif
Björn Peemöller 's avatar
Björn Peemöller committed
22
import Control.Monad.Writer
23
import Data.List             (mapAccumL)
24
import Data.Maybe            (fromMaybe, isJust)
25
import Network.URI           (escapeURIString, isUnreserved)
26
import System.Directory      (copyFile, doesFileExist)
27
import System.FilePath       ((</>), dropFileName, joinPath, takeBaseName)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
28

29
import Curry.Base.Ident      (ModuleIdent (..), QualIdent (..), unqualify)
30
import Curry.Base.Monad
Björn Peemöller 's avatar
Björn Peemöller committed
31
import Curry.Base.Pretty     (text)
32
import Curry.Files.Filenames (moduleNameToFile)
33
import Curry.Files.PathUtils (readModule, lookupCurryFile)
34
import Curry.Syntax          (Module (..), lexSource)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
35

Björn Peemöller 's avatar
Björn Peemöller committed
36
37
import Html.SyntaxColoring

Björn Peemöller 's avatar
Björn Peemöller committed
38
import Base.Messages
39
import CompilerOpts          (Options (..), WarnOpts (..))
Björn Peemöller 's avatar
Björn Peemöller committed
40
import CurryBuilder          (buildCurry)
41
42
import Modules               (loadAndCheckModule)
import Transformations       (qual)
43
44
45
46
import Paths_curry_frontend  (getDataFileName)

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

48
49
-- translate source file into HTML file with syntaxcoloring
-- @param sourcefilename
Björn Peemöller 's avatar
Björn Peemöller committed
50
source2html :: Options -> FilePath -> CYIO ()
51
source2html opts f = do
52
53
54
  let baseName   = takeBaseName f
      outDir     = fromMaybe (dropFileName f) $ optHtmlDir opts
      outFile    = outDir </> baseName ++ "_curry.html"
55
  srcFile <- liftIO $ lookupCurryFile ("." : optImportPaths opts) f
56
57
  (m, program) <- filename2program opts (fromMaybe f srcFile)
  liftIO $ writeFile outFile (program2html m program)
58
59
60
61
62
63
64
65
66
67
68
69
  liftIO $ updateCSSFile outDir

updateCSSFile :: FilePath -> IO ()
updateCSSFile dir = do
  src <- getDataFileName cssFile
  let target = dir </> cssFile
  exists  <- doesFileExist target
  if not exists
    then copyFile src target
    else do
      same <- (==) <$> readFile src <*> readFile target
      unless same $ copyFile src target
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
70

71
72
73
-- @param importpaths
-- @param filename
-- @return program
74
filename2program :: Options -> String -> CYIO (ModuleIdent, [Code])
75
filename2program opts f = do
Björn Peemöller 's avatar
Björn Peemöller committed
76
  mbModule <- liftIO $ readModule f
77
  case mbModule of
78
    Nothing  -> failMessages [message $ text $ "Missing file: " ++ f]
79
    Just src -> do
80
81
82
      toks  <- liftCYM $ lexSource f src
      typed@(Module _ m _ _ _) <- fullParse opts f src
      return (m, genProgram typed toks)
83
84
85
86
87
88
89
90

-- |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
91
fullParse opts fn _ = do
92
  buildCurry (opts { optTargetTypes = []}) fn
93
  (env, mdl) <- loadAndCheckModule opts' fn
94
  return (fst $ qual opts env mdl)
95
96
97
98
  where
  opts' = opts { optWarnOpts    = (optWarnOpts opts) { wnWarn = False }
               , optTargetTypes = []
               }
Björn Peemöller 's avatar
Björn Peemöller committed
99

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

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

139
140
141
escIdent :: QualIdent -> String
escIdent = htmlQuote . show . unqualify

142
143
144
145
146
147
148
149
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
150

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

171
172
173
174
175
176
177
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
178

179
180
181
182
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
makeRelativePath cur new
  | cur == new = ""
  | otherwise  = makeTopPath cur </> moduleNameToFile new ++ "_curry.html"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
183

184
185
makeTopPath :: ModuleIdent -> String
makeTopPath m = joinPath $ replicate (length (midQualifiers m) - 1) ".."
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
186
187

isCall :: Code -> Bool
188
189
190
191
192
193
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
194
195

isDecl :: Code -> Bool
196
197
198
199
200
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
201
202
203

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

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