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

Björn Peemöller 's avatar
Björn Peemöller committed
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 ()
Björn Peemöller 's avatar
Björn Peemöller committed
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
Björn Peemöller 's avatar
Björn Peemöller committed
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]
Björn Peemöller 's avatar
Björn Peemöller committed
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]
Björn Peemöller 's avatar
Björn Peemöller committed
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
Björn Peemöller 's avatar
Björn Peemöller committed
108
-- @param code
109
-- @return css class of the code
Björn Peemöller 's avatar
Björn Peemöller committed
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"
Björn Peemöller 's avatar
Björn Peemöller committed
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
Björn Peemöller 's avatar
Björn Peemöller committed
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