CurryHtml.hs 6.12 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)
Björn Peemöller 's avatar
Björn Peemöller committed
23
import Curry.Base.Message
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
59
60
61
62
63
64
65
66
67
68
      case runMsg (lexSource f src) of
        Left e          -> left [e]
        Right (toks, _) -> do
          typed <- fullParse opts f src
          return (genProgram typed toks)

-- |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
69
fullParse opts fn _ = do
70
71
72
  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
73

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
74
75
76
77
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
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
104
105
106
107
108

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

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

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

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

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

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

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

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