Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry
curry-frontend
Commits
e5d92b76
Commit
e5d92b76
authored
May 20, 2014
by
Björn Peemöller
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Refactored HTML generation
parent
54df07fd
Changes
3
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
514 additions
and
802 deletions
+514
-802
src/Html/CurryHtml.hs
src/Html/CurryHtml.hs
+74
-108
src/Html/SyntaxColoring.hs
src/Html/SyntaxColoring.hs
+416
-670
src/Html/currydoc.css
src/Html/currydoc.css
+24
-24
No files found.
src/Html/CurryHtml.hs
View file @
e5d92b76
...
...
@@ -16,7 +16,6 @@ module Html.CurryHtml (source2html) where
import
Control.Monad.Writer
import
Control.Monad.Trans.Either
import
Data.Char
(
toLower
)
import
Data.Maybe
(
fromMaybe
,
isJust
)
import
System.FilePath
((
</>
),
dropFileName
,
takeBaseName
)
...
...
@@ -24,14 +23,15 @@ import Curry.Base.Ident (QualIdent (..), unqualify)
import
Curry.Base.Message
import
Curry.Base.Pretty
(
text
)
import
Curry.Files.PathUtils
(
readModule
,
lookupCurryFile
)
import
Curry.Syntax
(
Module
,
lexSource
,
parseModule
)
import
Curry.Syntax
(
Module
,
lexSource
)
import
Html.SyntaxColoring
import
Base.Messages
import
CompilerOpts
(
Options
(
..
)
,
TargetType
(
..
),
defaultOptions
)
import
CompilerOpts
(
Options
(
..
))
import
CurryBuilder
(
buildCurry
)
import
Modules
(
loadAndCheckModule
,
checkModuleHeader
)
import
Modules
(
loadAndCheckModule
)
import
Transformations
(
qual
)
--- translate source file into HTML file with syntaxcoloring
--- @param sourcefilename
...
...
@@ -47,113 +47,84 @@ source2html opts f = do
--- @param importpaths
--- @param filename
--- @return program
filename2program
::
Options
->
String
->
CYIO
Program
filename2program
::
Options
->
String
->
CYIO
[
Code
]
filename2program
opts
f
=
do
mbModule
<-
liftIO
$
readModule
f
case
mbModule
of
Nothing
->
left
[
message
$
text
$
"Missing file: "
++
f
]
Just
src
->
do
typed
<-
liftIO
$
fromIO
$
fullParse
opts
f
src
checked
<-
liftIO
$
fromIO
$
fullParse
(
opts
{
optTargetTypes
=
[
UntypedAbstractCurry
]})
f
src
let
parsed
=
parse
f
src
lexed
=
lexSource
f
src
return
$
genProgram
src
[
typed
,
checked
,
parsed
]
lexed
{- |Return the result of a syntactical analysis of the source program 'src'.
The result is the syntax tree of the program (type 'Module'; see Module
"CurrySyntax").
-}
parse
::
FilePath
->
String
->
MessageM
Module
parse
fn
src
=
parseModule
fn
src
>>=
genCurrySyntax
where
genCurrySyntax
mod1
=
do
checked
<-
lift
$
runEitherT
$
checkModuleHeader
defaultOptions
fn
mod1
case
checked
of
Left
hdrErrs
->
failWith
$
show
$
head
hdrErrs
Right
mdl
->
return
mdl
{- |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
->
MessageIO
Module
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
fullParse
opts
fn
_
=
do
errs
<-
liftIO
$
makeInterfaces
opts
fn
if
null
errs
then
do
checked
<-
liftIO
$
runEitherT
$
loadAndCheckModule
opts
fn
case
checked
of
Left
errs'
->
failWith
$
show
$
head
errs'
Right
(
_
,
mod'
)
->
return
mod'
else
failWith
$
show
$
head
errs
-- Generates interface files for importes modules, if they don't exist or
-- if they are not up-to-date.
makeInterfaces
::
Options
->
FilePath
->
IO
[
Message
]
makeInterfaces
opts
fn
=
do
res
<-
runEitherT
$
buildCurry
opts
fn
case
res
of
Left
errs
->
return
errs
Right
_
->
return
[]
buildCurry
(
opts
{
optTargetTypes
=
[]
})
fn
(
env
,
mdl
)
<-
loadAndCheckModule
opts
fn
return
(
fst
$
qual
opts
env
mdl
)
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
program2html
::
String
->
Program
->
String
program2html
modulname
codes
=
"<html>
\n
<head>
\n
<title>Module "
++
modulname
++
"</title>
\n
"
++
"<link rel=
\"
stylesheet
\"
type=
\"
text/css
\"
href=
\"
currydoc.css
\"
>"
++
"</link>
\n
</head>
\n
"
++
"<body style=
\"
font-family:'Courier New', Arial;
\"
>
\n
<pre>
\n
"
++
concatMap
(
code2html
True
.
(
\
(
_
,
_
,
c
)
->
c
))
codes
++
"<pre>
\n
</body>
\n
</html>"
code2html
::
Bool
->
Code
->
String
code2html
ownClass
code
@
(
CodeWarning
_
c
)
=
(
if
ownClass
then
spanTag
(
code2class
code
)
else
id
)
(
code2html
False
c
)
code2html
ownClass
code
@
(
Commentary
_
)
=
(
if
ownClass
then
spanTag
(
code2class
code
)
else
id
)
(
replace
'<'
"<span><</span>"
(
code2string
code
))
code2html
ownClass
c
|
isCall
c
&&
ownClass
=
maybe
tag
(
addHtmlLink
tag
)
(
getQualIdent
c
)
|
isDecl
c
&&
ownClass
=
maybe
tag
(
addHtmlAnchor
tag
)
(
getQualIdent
c
)
|
otherwise
=
tag
where
tag
=
(
if
ownClass
then
spanTag
(
code2class
c
)
else
id
)
(
htmlQuote
(
code2string
c
))
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><</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
))
spanTag
::
String
->
String
->
String
spanTag
[]
str
=
str
spanTag
cl
str
=
"<span class=
\"
"
++
cl
++
"
\"
>"
++
str
++
"</span>"
-- which code has which c
olor
-- which code has which c
ss class
-- @param code
-- @return c
olor
of the code
-- @return c
ss class
of the code
code2class
::
Code
->
String
code2class
(
Keyword
_
)
=
"keyword"
code2class
(
Space
_
)
=
""
code2class
NewLine
=
""
code2class
(
ConstructorName
k
_
)
=
"constructorname_"
++
showLower
k
code2class
(
Function
k
_
)
=
"function_"
++
showLower
k
code2class
(
ModuleName
_
)
=
"modulename"
code2class
(
Commentary
_
)
=
"commentary"
code2class
(
NumberCode
_
)
=
"numbercode"
code2class
(
StringCode
_
)
=
"stringcode"
code2class
(
CharCode
_
)
=
"charcode"
code2class
(
Symbol
_
)
=
"symbol"
code2class
(
Identifier
k
_
)
=
"identifier_"
++
showLower
k
code2class
(
TypeConstructor
k
_
)
=
"typeconstructor_"
++
showLower
k
code2class
(
CodeWarning
_
_
)
=
"codewarning"
code2class
(
NotParsed
_
)
=
"notparsed"
showLower
::
Show
a
=>
a
->
String
showLower
=
map
toLower
.
show
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"
replace
::
Char
->
String
->
String
->
String
replace
old
new
=
foldr
(
\
x
->
if
x
==
old
then
(
new
++
)
else
([
x
]
++
))
""
...
...
@@ -174,27 +145,22 @@ addHtmlLink str qid =
"</a>"
isCall
::
Code
->
Bool
isCall
(
TypeConstructor
TypeExport
_
)
=
True
isCall
(
TypeConstructor
_
_
)
=
False
isCall
(
Identifier
_
_
)
=
False
isCall
code
=
not
(
isDecl
code
)
&&
isJust
(
getQualIdent
code
)
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
)
isDecl
::
Code
->
Bool
isDecl
(
Cons
tructorName
Cons
tr
Decla
_
)
=
True
isDecl
(
Function
FunDecl
_
)
=
True
isDecl
(
TypeCons
tructor
TypeDecla
_
)
=
True
isDecl
_
=
False
isDecl
(
Data
Cons
ConsDecla
re
_
)
=
True
isDecl
(
Function
Fun
c
Decl
are
_
)
=
True
isDecl
(
TypeCons
TypeDecla
re
_
)
=
True
isDecl
_
=
False
-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded
::
String
->
String
string2urlencoded
=
id
{-
string2urlencoded [] = []
string2urlencoded (c:cs)
| isAlphaNum c = c : string2urlencoded cs
| c == ' ' = '+' : string2urlencoded cs
| otherwise = show (ord c) ++ (if null cs then "" else ".") ++ string2urlencoded cs
-}
htmlQuote
::
String
->
String
htmlQuote
[]
=
[]
...
...
src/Html/SyntaxColoring.hs
View file @
e5d92b76
This diff is collapsed.
Click to expand it.
src/Html/currydoc.css
View file @
e5d92b76
...
...
@@ -7,28 +7,28 @@ body { background: white; color: black }
/* Show hyperlinks without underscore */
a
:visited
,
a
:link
,
a
:active
{
text-decoration
:
none
}
.keyword
{
color
:
blue
}
.constructorname_constrpattern
{
color
:
#FF00FF
}
.constructorname_constrcall
{
color
:
#FF00FF
}
.constructorname_constrdecla
{
color
:
#FF00FF
}
.constructorname_otherconstrkind
{
color
:
#FF00FF
}
.typeconstructor_typedecla
{
color
:
#ff7f50
}
.typeconstructor_typeuse
{
color
:
#ff7f50
}
.typeconstructor_typeexport
{
color
:
#ff7f50
}
.function_infixfunction
{
color
:
#800080
}
.function_typsig
{
color
:
#800080
}
.function_fundecl
{
color
:
#800080
}
.function_functioncall
{
color
:
#800080
}
.function_otherfunctionkind
{
color
:
#800080
}
.moduleName
{
color
:
#800000
}
.commentary
{
color
:
green
}
.numberCode
{
color
:
#008080
}
.stringCode
{
color
:
#800000
}
.charCode
{
color
:
#800000
}
.linenumbers
{
width
:
40px
;
text-align
:
right
;
color
:
grey
;
padding-right
:
10px
;
border-right
:
1px
solid
grey
;
}
.sourcecode
{
padding-left
:
10px
;
}
.pragma
{
color
:
green
}
.comment
{
color
:
green
}
.keyword
{
color
:
blue
}
.symbol
{
color
:
#C0C0C0
}
.identifier_iddecl
{
color
:
black
}
.identifier_idoccur
{
color
:
black
}
.identifier_unknownid
{
color
:
black
}
.codeWarning
{
font-weight
:
bold
;
font-style
:
italic
;
color
:
red
}
.codeError
{
font-style
:
italic
;
color
:
#a52a2a
}
.notParsed
{
font-style
:
italic
;
color
:
#C0C0C0
}
\ No newline at end of file
.type
{
color
:
#ff7f50
}
.cons
{
color
:
#ff00ff
}
.label
{
color
:
#90EE90
}
.func
{
color
:
#800080
}
.ident
{
color
:
black
}
.module
{
color
:
#800000
}
.number
{
color
:
#008080
}
.string
{
color
:
#800000
}
.char
{
color
:
#800000
}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment