CurryHtml.hs 6.07 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.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"
Björn Peemöller 's avatar
Björn Peemöller committed
42
  srcFile <- liftIO $ lookupCurryFile (optImportPaths opts) f
43
  program <- filename2program opts (fromMaybe f srcFile)
44
  liftIO $ writeFile outFile (program2html baseName program)
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
Björn Peemöller 's avatar
Björn Peemöller committed
53
    Nothing  -> left [message $ text $ "Missing file: " ++ f]
54
    Just src -> do
55
56
57
      case lexSource f src of
        Left  err  -> left [err]
        Right toks -> do
58
59
60
61
62
63
64
65
66
67
          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
68
fullParse opts fn _ = do
69
70
71
  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
72

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

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

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

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

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

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

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

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

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