CurryHtml.hs 6.02 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.Maybe            (fromMaybe, isJust)
19
import System.FilePath       ((</>), dropFileName, takeBaseName)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
20

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

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

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

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

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

-- |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
66
fullParse opts fn _ = do
67
68
69
  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
70

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
71
72
73
74
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
75
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
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
101
102
103
104
105

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

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

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

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

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

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

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

-- 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