Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
f351a076
Commit
f351a076
authored
Apr 07, 2016
by
Jan Rasmus Tikovsky
Browse files
Fixed representation of HTML documentation of Curry modules
parent
378e06d3
Changes
2
Hide whitespace changes
Inline
Side-by-side
src/Html/CurryHtml.hs
View file @
f351a076
...
...
@@ -20,8 +20,8 @@ import Network.URI (escapeURIString, isUnreserved)
import
System.Directory
(
copyFile
,
doesFileExist
)
import
System.FilePath
((
</>
))
import
Curry.Base.Ident
(
ModuleIdent
(
..
),
QualIdent
(
..
)
,
unqualify
,
moduleName
)
import
Curry.Base.Ident
(
ModuleIdent
(
..
),
Ident
(
..
),
QualIdent
(
..
)
,
unqualify
,
moduleName
)
import
Curry.Base.Monad
(
CYIO
,
liftCYM
,
failMessages
)
import
Curry.Base.Pretty
((
<+>
),
text
,
vcat
)
import
Curry.Files.PathUtils
(
readModule
)
...
...
@@ -112,25 +112,27 @@ program2html m codes = unlines
,
"</html>"
]
where
titleHtml
=
"Module "
++
show
m
titleHtml
=
"Module "
++
moduleName
m
lineHtml
=
unlines
$
map
show
[
1
..
length
(
lines
codeHtml
)]
codeHtml
=
concat
$
snd
$
mapAccumL
(
code2html
m
)
[]
codes
code2html
::
ModuleIdent
->
[
QualIdent
]
->
Code
->
([
QualIdent
],
String
)
code2html
m
defs
c
|
isCall
c
=
(
defs
,
maybe
tag
(
add
Html
Link
m
tag
)
(
getQualIdent
c
))
|
isCall
c
=
(
defs
,
maybe
tag
(
add
Entity
Link
m
tag
)
(
getQualIdent
c
))
|
isDecl
c
=
case
getQualIdent
c
of
Just
i
|
i
`
notElem
`
defs
->
(
i
:
defs
,
spanTag
(
code2class
c
)
(
escIdent
i
)
(
escCode
c
))
_
->
(
defs
,
tag
)
|
otherwise
=
(
defs
,
tag
)
|
otherwise
=
case
c
of
ModuleName
m'
->
(
defs
,
addModuleLink
m
m'
tag
)
_
->
(
defs
,
tag
)
where
tag
=
spanTag
(
code2class
c
)
""
(
escCode
c
)
escCode
::
Code
->
String
escCode
=
htmlQuote
.
code2string
escIdent
::
QualIdent
->
String
escIdent
=
htmlQuote
.
show
.
unqualify
escIdent
=
htmlQuote
.
idName
.
unqualify
spanTag
::
String
->
String
->
String
->
String
spanTag
clV
idV
str
...
...
@@ -160,12 +162,16 @@ code2class (NumberCode _) = "number"
code2class
(
StringCode
_
)
=
"string"
code2class
(
CharCode
_
)
=
"char"
addHtmlLink
::
ModuleIdent
->
String
->
QualIdent
->
String
addHtmlLink
m
str
qid
=
addModuleLink
::
ModuleIdent
->
ModuleIdent
->
String
->
String
addModuleLink
m
m'
str
=
"<a href=
\"
"
++
makeRelativePath
m
m'
++
"
\"
>"
++
str
++
"</a>"
addEntityLink
::
ModuleIdent
->
String
->
QualIdent
->
String
addEntityLink
m
str
qid
=
"<a href=
\"
"
++
modPath
++
"#"
++
fragment
++
"
\"
>"
++
str
++
"</a>"
where
modPath
=
maybe
""
(
makeRelativePath
m
)
mmid
fragment
=
string2urlencoded
(
show
ident
)
fragment
=
string2urlencoded
(
idName
ident
)
(
mmid
,
ident
)
=
(
qidModule
qid
,
qidIdent
qid
)
makeRelativePath
::
ModuleIdent
->
ModuleIdent
->
String
...
...
src/Html/SyntaxColoring.hs
View file @
f351a076
...
...
@@ -21,7 +21,7 @@ module Html.SyntaxColoring
)
where
import
Data.Function
(
on
)
import
Data.List
(
intercalate
,
sortBy
)
import
Data.List
(
sortBy
)
import
Curry.Base.Ident
import
Curry.Base.Position
...
...
@@ -83,7 +83,7 @@ data IdentUsage
-- @param lex-Result
-- @return program
genProgram
::
String
->
Module
->
[(
Position
,
Token
)]
->
[
Code
]
genProgram
fn
m
toks
=
tokenToCode
s
(
first
fn
)
(
idsModule
m
)
toks
genProgram
fn
m
toks
=
encodeTok
s
(
first
fn
)
(
idsModule
m
)
toks
-- @param code
-- @return qid if available
...
...
@@ -94,43 +94,38 @@ getQualIdent (Identifier _ qid) = Just qid
getQualIdent
(
TypeCons
_
qid
)
=
Just
qid
getQualIdent
_
=
Nothing
tokenToCode
s
::
Position
->
[
Code
]
->
[(
Position
,
Token
)]
->
[
Code
]
tokenToCodes
_
_
[]
=
[]
tokenToCode
s
cur
Pos
ids
toks
@
((
pos
,
tok
)
:
ts
)
encodeTok
s
::
Position
->
[
Code
]
->
[(
Position
,
Token
)]
->
[
Code
]
encodeToks
_
_
[]
=
[]
encodeTok
s
cur
ids
toks
@
((
pos
,
tok
)
:
ts
)
-- advance line
|
line
curPos
<
line
pos
=
NewLine
:
tokenToCodes
(
nl
curPos
)
ids
toks
|
line
cur
<
line
pos
=
NewLine
:
encodeToks
(
nl
cur
)
ids
toks
-- advance column
|
column
curPos
<
column
pos
=
Space
colDiff
:
tokenToCodes
(
incr
curPos
colDiff
)
ids
toks
|
isPragmaToken
tok
=
let
(
pragmas
,
(
end
:
rest
))
=
break
(
isPragmaEnd
.
snd
)
toks
str
=
intercalate
" "
$
map
(
showToken
.
snd
)
(
pragmas
++
[
end
])
in
Pragma
str
:
tokenToCodes
(
incr
curPos
(
length
str
))
ids
rest
-- no identifier token
|
not
(
isTokenIdentifier
tok
)
=
tokenToCode
tok
:
tokenToCodes
newPos
ids
ts
-- identifier, but no more information
|
null
ids
=
tokenToCode
tok
:
tokenToCodes
newPos
ids
ts
|
tokenStr
==
code2string
(
head
ids
)
=
head
ids
:
tokenToCodes
newPos
(
tail
ids
)
ts
|
otherwise
=
tokenToCodes
curPos
(
tail
ids
)
toks
|
column
cur
<
column
pos
=
let
d
=
column
pos
-
column
cur
in
Space
d
:
encodeToks
(
incr
cur
d
)
ids
toks
-- pragma token
|
isPragmaToken
tok
=
let
(
ps
,
(
end
:
rest
))
=
break
(
isPragmaEnd
.
snd
)
toks
s
=
unwords
$
map
(
showToken
.
snd
)
(
ps
++
[
end
])
in
Pragma
s
:
encodeToks
(
incr
cur
(
length
s
))
ids
rest
-- identifier token
|
isIdentTok
tok
=
case
ids
of
[]
->
encodeTok
tok
:
encodeToks
newPos
[]
ts
(
i
:
is
)
|
tokenStr
==
code2string
i
->
i
:
encodeToks
newPos
is
ts
|
otherwise
->
encodeToks
cur
is
toks
-- other token
|
otherwise
=
encodeTok
tok
:
encodeToks
newPos
ids
ts
where
colDiff
=
column
pos
-
column
curPos
tokenStr
=
showToken
tok
newPos
=
incr
cur
Pos
(
length
tokenStr
)
newPos
=
incr
cur
(
length
tokenStr
)
code2string
::
Code
->
String
code2string
(
Keyword
s
)
=
s
code2string
(
Space
i
)
=
replicate
i
' '
code2string
NewLine
=
"
\n
"
code2string
(
Pragma
s
)
=
s
code2string
(
DataCons
_
qid
)
=
id
Name
$
unqualify
qid
code2string
(
TypeCons
_
qid
)
=
id
Name
$
unqualify
qid
code2string
(
Function
_
qid
)
=
id
Name
$
unqualify
qid
code2string
(
Identifier
_
qid
)
=
id
Name
$
unqualify
qid
code2string
(
DataCons
_
qid
)
=
qual
Name
qid
code2string
(
TypeCons
_
qid
)
=
qual
Name
qid
code2string
(
Function
_
qid
)
=
qual
Name
qid
code2string
(
Identifier
_
qid
)
=
qual
Name
qid
code2string
(
ModuleName
mid
)
=
moduleName
mid
code2string
(
Commentary
s
)
=
s
code2string
(
NumberCode
s
)
=
s
...
...
@@ -138,22 +133,22 @@ code2string (StringCode s) = s
code2string
(
CharCode
s
)
=
s
code2string
(
Symbol
s
)
=
s
tokenToCode
::
Token
->
Code
tokenToCode
tok
@
(
Token
c
at
_
)
|
c
at
`
elem
`
numCategories
=
NumberCode
(
showToken
tok
)
|
c
at
==
CharTok
=
CharCode
(
showToken
tok
)
|
c
at
==
StringTok
=
StringCode
(
showToken
tok
)
|
c
at
`
elem
`
keywordCategories
=
Keyword
(
showToken
tok
)
|
c
at
`
elem
`
specialIdentCategories
=
Keyword
(
showToken
tok
)
|
c
at
`
elem
`
punctuationCategories
=
Symbol
(
showToken
tok
)
|
c
at
`
elem
`
reservedOpsCategories
=
Symbol
(
showToken
tok
)
|
c
at
`
elem
`
commentCategories
=
Commentary
(
showToken
tok
)
|
c
at
`
elem
`
identCategories
=
Identifier
IdUnknown
$
qualify
$
mkIdent
encodeTok
::
Token
->
Code
encodeTok
tok
@
(
Token
c
_
)
|
c
`
elem
`
numCategories
=
NumberCode
(
showToken
tok
)
|
c
==
CharTok
=
CharCode
(
showToken
tok
)
|
c
==
StringTok
=
StringCode
(
showToken
tok
)
|
c
`
elem
`
keywordCategories
=
Keyword
(
showToken
tok
)
|
c
`
elem
`
specialIdentCategories
=
Keyword
(
showToken
tok
)
|
c
`
elem
`
punctuationCategories
=
Symbol
(
showToken
tok
)
|
c
`
elem
`
reservedOpsCategories
=
Symbol
(
showToken
tok
)
|
c
`
elem
`
commentCategories
=
Commentary
(
showToken
tok
)
|
c
`
elem
`
identCategories
=
Identifier
IdUnknown
$
qualify
$
mkIdent
$
showToken
tok
|
c
at
`
elem
`
whiteSpaceCategories
=
Space
0
|
c
at
`
elem
`
pragmaCategories
=
Pragma
(
showToken
tok
)
|
c
`
elem
`
whiteSpaceCategories
=
Space
0
|
c
`
elem
`
pragmaCategories
=
Pragma
(
showToken
tok
)
|
otherwise
=
internalError
$
"SyntaxColoring.
tokenToCode
: Unknown token"
++
showToken
tok
"SyntaxColoring.
encodeTok
: Unknown token"
++
showToken
tok
numCategories
::
[
Category
]
numCategories
=
[
IntTok
,
FloatTok
]
...
...
@@ -187,13 +182,13 @@ identCategories :: [Category]
identCategories
=
[
Id
,
QId
,
Sym
,
QSym
,
SymDot
,
SymMinus
,
SymMinusDot
]
isPragmaToken
::
Token
->
Bool
isPragmaToken
(
Token
c
at
_
)
=
c
at
`
elem
`
pragmaCategories
isPragmaToken
(
Token
c
_
)
=
c
`
elem
`
pragmaCategories
isPragmaEnd
::
Token
->
Bool
isPragmaEnd
(
Token
c
at
_
)
=
c
at
==
PragmaEnd
isPragmaEnd
(
Token
c
_
)
=
c
==
PragmaEnd
is
TokenIdentifier
::
Token
->
Bool
is
TokenIdentifier
(
Token
c
at
_
)
=
c
at
`
elem
`
identCategories
is
IdentTok
::
Token
->
Bool
is
IdentTok
(
Token
c
_
)
=
c
`
elem
`
identCategories
whiteSpaceCategories
::
[
Category
]
whiteSpaceCategories
=
[
EOF
,
VSemicolon
,
VRightBrace
]
...
...
@@ -233,19 +228,7 @@ idsModule (Module _ mid es is ds) =
let
hdrCodes
=
ModuleName
mid
:
idsExportSpec
es
impCodes
=
concatMap
idsImportDecl
(
sortBy
cmpImportDecl
is
)
dclCodes
=
concatMap
idsDecl
(
sortBy
cmpDecl
ds
)
in
map
(
addModuleIdent
mid
)
$
hdrCodes
++
impCodes
++
dclCodes
addModuleIdent
::
ModuleIdent
->
Code
->
Code
addModuleIdent
mid
c
@
(
Function
x
qid
)
|
hasGlobalScope
(
unqualify
qid
)
=
Function
x
(
qualQualify
mid
qid
)
|
otherwise
=
c
addModuleIdent
mid
cn
@
(
DataCons
x
qid
)
|
not
$
isQualified
qid
=
DataCons
x
(
qualQualify
mid
qid
)
|
otherwise
=
cn
addModuleIdent
mid
tc
@
(
TypeCons
x
qid
)
|
not
$
isQualified
qid
=
TypeCons
x
(
qualQualify
mid
qid
)
|
otherwise
=
tc
addModuleIdent
_
c
=
c
in
hdrCodes
++
impCodes
++
dclCodes
-- Exports
...
...
@@ -496,8 +479,8 @@ showAttr (IntAttributes i _) = show i
showAttr
(
FloatAttributes
f
_
)
=
show
f
showAttr
(
StringAttributes
s
_
)
=
show
s
showAttr
(
IdentAttributes
m
i
)
|
null
m
=
show
$
qualify
(
mkIdent
i
)
|
otherwise
=
show
$
qualifyWith
(
mkMIdent
m
)
(
mkIdent
i
)
|
null
m
=
idName
$
(
mkIdent
i
)
|
otherwise
=
qualName
$
qualifyWith
(
mkMIdent
m
)
(
mkIdent
i
)
showAttr
(
OptionsAttributes
mt
s
)
=
showTool
mt
++
' '
:
s
showTool
::
Maybe
String
->
String
...
...
Write
Preview
Supports
Markdown
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