CurryHtml.hs 6.04 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
18
import Control.Monad.Writer
import Control.Monad.Trans.Either

19
import Data.Maybe            (fromMaybe, isJust)
20
import System.FilePath       ((</>), dropFileName, takeBaseName)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
21

22
import Curry.Base.Ident      (QualIdent (..), unqualify)
23
import Curry.Base.Monad
Björn Peemöller 's avatar
Björn Peemöller committed
24
import Curry.Base.Pretty     (text)
25
import Curry.Files.PathUtils (readModule, lookupCurryFile)
26
import Curry.Syntax          (Module, lexSource)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
27

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

Björn Peemöller 's avatar
Björn Peemöller committed
30
import Base.Messages
31
import CompilerOpts          (Options (..))
Björn Peemöller 's avatar
Björn Peemöller committed
32
import CurryBuilder          (buildCurry)
33
34
import Modules               (loadAndCheckModule)
import Transformations       (qual)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
35

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

47
48
49
-- @param importpaths
-- @param filename
-- @return program
50
filename2program :: Options -> String -> CYIO [Code]
51
filename2program opts f = do
Björn Peemöller 's avatar
Björn Peemöller committed
52
  mbModule <- liftIO $ readModule f
53
  case mbModule of
Björn Peemöller 's avatar
Björn Peemöller committed
54
    Nothing  -> left [message $ text $ "Missing file: " ++ f]
55
    Just src -> do
56
57
58
      toks <- liftCYM $ lexSource f src
      typed <- fullParse opts f src
      return (genProgram typed toks)
59
60
61
62
63
64
65
66

-- |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
67
fullParse opts fn _ = do
68
69
70
  buildCurry (opts { optTargetTypes = []}) fn
  (env, mdl) <- loadAndCheckModule opts fn
  return (fst $ qual opts env mdl)
Björn Peemöller 's avatar
Björn Peemöller committed
71

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
72
73
74
75
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
program2html :: String -> [Code] -> String
program2html modulname codes = unlines
  [ "<!DOCTYPE html>"
  , "<html>", "<head>", "<title>Module " ++ modulname ++ "</title>"
  , "<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\"/>"
  , "</head>"
  , "<body style=\"font-family:'Courier New', Arial;\">"
  , "<table><tbody><tr>"
  , "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"
  , "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"
  , "</tr></tbody></table>"
  , "</body>"
  , "</html>"
  ]
  where
  lineHtml = unlines $ map show [1 .. length (lines codeHtml)]
  codeHtml = concatMap code2html codes

code2html :: Code -> String
code2html code@(Commentary _) =
  spanTag (code2class code) (replace '<' "<span>&lt</span>" (code2string code))
code2html c
  | isCall c  = maybe tag (addHtmlLink   tag) (getQualIdent c)
  | isDecl c  = maybe tag (addHtmlAnchor tag) (getQualIdent c)
  | otherwise = tag
  where tag = spanTag (code2class c) (htmlQuote (code2string c))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
102
103
104
105
106

spanTag :: String -> String -> String
spanTag [] str = str
spanTag cl str = "<span class=\"" ++ cl ++ "\">" ++ str ++ "</span>"

107
-- which code has which css class
108
-- @param code
109
-- @return css class of the code
110
code2class :: Code -> String
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
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"
126

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
127
128
129
130
replace :: Char -> String -> String -> String
replace old new = foldr (\ x -> if x == old then (new ++) else ([x] ++)) ""

addHtmlAnchor :: String -> QualIdent -> String
131
132
addHtmlAnchor str qid = "<a name=\"" ++ anchor ++ "\"></a>" ++ str
  where anchor = string2urlencoded (show (unqualify qid))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
133
134

addHtmlLink :: String -> QualIdent -> String
135
136
addHtmlLink str qid =
   let (maybeModIdent, ident) = (qidModule qid, qidIdent qid) in
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
137
138
139
140
141
   "<a href=\"" ++
   maybe "" (\ x -> show x ++ "_curry.html") maybeModIdent ++
   "#" ++
   string2urlencoded (show ident) ++
   "\">" ++
Björn Peemöller 's avatar
Björn Peemöller committed
142
   str ++
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
143
144
145
   "</a>"

isCall :: Code -> Bool
146
147
148
149
150
151
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
152
153

isDecl :: Code -> Bool
154
155
156
157
isDecl (DataCons ConsDeclare _) = True
isDecl (Function FuncDeclare _) = True
isDecl (TypeCons TypeDeclare _) = True
isDecl _                        = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177

-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
string2urlencoded = id

htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
  | c == '<'    = "&lt;"    ++ htmlQuote cs
  | c == '>'    = "&gt;"    ++ htmlQuote cs
  | c == '&'    = "&amp;"   ++ htmlQuote cs
  | c == '"'    = "&quot;"  ++ htmlQuote cs
  | c == '\228' = "&auml;"  ++ htmlQuote cs
  | c == '\246' = "&ouml;"  ++ htmlQuote cs
  | c == '\252' = "&uuml;"  ++ htmlQuote cs
  | c == '\196' = "&Auml;"  ++ htmlQuote cs
  | c == '\214' = "&Ouml;"  ++ htmlQuote cs
  | c == '\220' = "&Uuml;"  ++ htmlQuote cs
  | c == '\223' = "&szlig;" ++ htmlQuote cs
  | otherwise   = c : htmlQuote cs