Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
H
haddock
Manage
Activity
Members
Labels
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Model registry
Operate
Environments
Analyze
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Glasgow Haskell Compiler
haddock
Commits
622ea3f4
Commit
622ea3f4
authored
6 years ago
by
Oleg Grenrus
Committed by
Alec Theriault
6 years ago
Browse files
Options
Downloads
Patches
Plain Diff
Redo ParseModuleHeader
parent
8964666e
No related branches found
No related tags found
5 merge requests
!38
Make --no-tmp-comp-dir the default
,
!37
Adapt to latest xhtml version, various optimizations
,
!31
Support HsToken in DataDecl and ClassDecl
,
!12
Drop orphan instance when defined upstream.
,
!10
Haddock interfaces produced from `.hi` files
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+125
-93
125 additions, 93 deletions
haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
with
125 additions
and
93 deletions
haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+
125
−
93
View file @
622ea3f4
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
...
...
@@ -11,7 +12,8 @@
-----------------------------------------------------------------------------
module
Haddock.Interface.ParseModuleHeader
(
parseModuleHeader
)
where
import
Control.Monad
(
mplus
)
import
Control.Applicative
(
Alternative
(
..
))
import
Control.Monad
(
ap
)
import
Data.Char
import
DynFlags
import
Haddock.Parser
...
...
@@ -27,34 +29,44 @@ import RdrName
parseModuleHeader
::
DynFlags
->
Maybe
Package
->
String
->
(
HaddockModInfo
RdrName
,
MDoc
RdrName
)
parseModuleHeader
dflags
pkgName
str0
=
let
getKey
::
String
->
String
->
(
Maybe
String
,
String
)
getKey
key
str
=
case
parseKey
key
str
of
Nothing
->
(
Nothing
,
str
)
Just
(
value
,
rest
)
->
(
Just
value
,
rest
)
(
_moduleOpt
,
str1
)
=
getKey
"Module"
str0
(
descriptionOpt
,
str2
)
=
getKey
"Description"
str1
(
copyrightOpt
,
str3
)
=
getKey
"Copyright"
str2
(
licenseOpt
,
str4
)
=
getKey
"License"
str3
(
licenceOpt
,
str5
)
=
getKey
"Licence"
str4
(
spdxLicenceOpt
,
str6
)
=
getKey
"SPDX-License-Identifier"
str5
(
maintainerOpt
,
str7
)
=
getKey
"Maintainer"
str6
(
stabilityOpt
,
str8
)
=
getKey
"Stability"
str7
(
portabilityOpt
,
str9
)
=
getKey
"Portability"
str8
kvs
::
[(
String
,
String
)]
str1
::
String
(
kvs
,
str1
)
=
maybe
(
[]
,
str0
)
id
$
runP
fields
str0
-- trim whitespaces
trim
::
String
->
String
trim
=
dropWhile
isSpace
.
reverse
.
dropWhile
isSpace
.
reverse
getKey
::
String
->
Maybe
String
getKey
key
=
fmap
trim
(
lookup
key
kvs
)
descriptionOpt
=
getKey
"Description"
copyrightOpt
=
getKey
"Copyright"
licenseOpt
=
getKey
"License"
licenceOpt
=
getKey
"Licence"
spdxLicenceOpt
=
getKey
"SPDX-License-Identifier"
maintainerOpt
=
getKey
"Maintainer"
stabilityOpt
=
getKey
"Stability"
portabilityOpt
=
getKey
"Portability"
in
(
HaddockModInfo
{
hmi_description
=
parseString
dflags
<$>
descriptionOpt
,
hmi_copyright
=
copyrightOpt
,
hmi_license
=
spdxLicenceOpt
`
mplus
`
licenseOpt
`
mplus
`
licenceOpt
,
hmi_license
=
spdxLicenceOpt
<|>
licenseOpt
<|>
licenceOpt
,
hmi_maintainer
=
maintainerOpt
,
hmi_stability
=
stabilityOpt
,
hmi_portability
=
portabilityOpt
,
hmi_safety
=
Nothing
,
hmi_language
=
Nothing
,
-- set in LexParseRn
hmi_extensions
=
[]
-- also set in LexParseRn
},
parseParas
dflags
pkgName
str9
)
},
parseParas
dflags
pkgName
str1
)
-------------------------------------------------------------------------------
-- Small parser to parse module header.
-------------------------------------------------------------------------------
-- | Th
is function is
how we read keys.
-- | Th
e below is a small parser framework
how we read keys.
--
-- all fields in the header are optional and have the form
--
...
...
@@ -73,78 +85,98 @@ parseModuleHeader dflags pkgName str0 =
--
-- the value will be "this is a .. description" and the rest will begin
-- at "The module comment".
parseKey
::
String
->
String
->
Maybe
(
String
,
String
)
parseKey
key
toParse0
=
do
let
(
spaces0
,
toParse1
)
=
extractLeadingSpaces
(
dropWhile
(`
elem
`
[
'
\r
'
,
'
\n
'
])
toParse0
)
indentation
=
spaces0
afterKey0
<-
extractPrefix
key
toParse1
let
afterKey1
=
extractLeadingSpaces
afterKey0
afterColon0
<-
case
snd
afterKey1
of
':'
:
afterColon
->
return
afterColon
_
->
Nothing
let
(
_
,
afterColon1
)
=
extractLeadingSpaces
afterColon0
return
(
scanKey
True
indentation
afterColon1
)
where
scanKey
::
Bool
->
String
->
String
->
(
String
,
String
)
scanKey
_
_
[]
=
(
[]
,
[]
)
scanKey
isFirst
indentation
str
=
let
(
nextLine
,
rest1
)
=
extractNextLine
str
accept
=
isFirst
||
sufficientIndentation
||
allSpaces
sufficientIndentation
=
case
extractPrefix
indentation
nextLine
of
Just
(
c
:
_
)
|
isSpace
c
->
True
_
->
False
allSpaces
=
case
extractLeadingSpaces
nextLine
of
(
_
,
[]
)
->
True
_
->
False
in
if
accept
then
let
(
scanned1
,
rest2
)
=
scanKey
False
indentation
rest1
scanned2
=
case
scanned1
of
""
->
if
allSpaces
then
""
else
nextLine
_
->
nextLine
++
"
\n
"
++
scanned1
in
(
scanned2
,
rest2
)
else
(
[]
,
str
)
extractLeadingSpaces
::
String
->
(
String
,
String
)
extractLeadingSpaces
[]
=
(
[]
,
[]
)
extractLeadingSpaces
(
s
@
(
c
:
cs
))
|
isSpace
c
=
let
(
spaces1
,
cs1
)
=
extractLeadingSpaces
cs
in
(
c
:
spaces1
,
cs1
)
|
otherwise
=
(
[]
,
s
)
extractNextLine
::
String
->
(
String
,
String
)
extractNextLine
[]
=
(
[]
,
[]
)
extractNextLine
(
c
:
cs
)
|
c
==
'
\n
'
=
(
[]
,
cs
)
|
otherwise
=
let
(
line
,
rest
)
=
extractNextLine
cs
in
(
c
:
line
,
rest
)
-- comparison is case-insensitive.
extractPrefix
::
String
->
String
->
Maybe
String
extractPrefix
[]
s
=
Just
s
extractPrefix
_
[]
=
Nothing
extractPrefix
(
c1
:
cs1
)
(
c2
:
cs2
)
|
toUpper
c1
==
toUpper
c2
=
extractPrefix
cs1
cs2
|
otherwise
=
Nothing
data
C
=
C
{-# UNPACK #-}
!
Int
Char
newtype
P
a
=
P
{
unP
::
[
C
]
->
Maybe
([
C
],
a
)
}
deriving
Functor
instance
Applicative
P
where
pure
x
=
P
$
\
s
->
Just
(
s
,
x
)
(
<*>
)
=
ap
instance
Monad
P
where
return
=
pure
m
>>=
k
=
P
$
\
s0
->
do
(
s1
,
x
)
<-
unP
m
s0
unP
(
k
x
)
s1
instance
Alternative
P
where
empty
=
P
$
\
_
->
Nothing
a
<|>
b
=
P
$
\
s
->
unP
a
s
<|>
unP
b
s
runP
::
P
a
->
String
->
Maybe
a
runP
p
input
=
fmap
snd
(
unP
p
input'
)
where
input'
=
concat
[
zipWith
C
[
0
..
]
l
++
[
C
(
length
l
)
'
\n
'
]
|
l
<-
lines
input
]
-------------------------------------------------------------------------------
--
-------------------------------------------------------------------------------
curInd
::
P
Int
curInd
=
P
$
\
s
->
Just
.
(,)
s
$
case
s
of
[]
->
0
C
i
_
:
_
->
i
rest
::
P
String
rest
=
P
$
\
cs
->
Just
(
[]
,
[
c
|
C
_
c
<-
cs
])
munch
::
(
Int
->
Char
->
Bool
)
->
P
String
munch
p
=
P
$
\
cs
->
let
(
xs
,
ys
)
=
takeWhileMaybe
p'
cs
in
Just
(
ys
,
xs
)
where
p'
(
C
i
c
)
|
p
i
c
=
Just
c
|
otherwise
=
Nothing
munch1
::
(
Int
->
Char
->
Bool
)
->
P
String
munch1
p
=
P
$
\
s
->
case
s
of
[]
->
Nothing
(
c
:
cs
)
|
Just
c'
<-
p'
c
->
let
(
xs
,
ys
)
=
takeWhileMaybe
p'
cs
in
Just
(
ys
,
c'
:
xs
)
|
otherwise
->
Nothing
where
p'
(
C
i
c
)
|
p
i
c
=
Just
c
|
otherwise
=
Nothing
char
::
Char
->
P
Char
char
c
=
P
$
\
s
->
case
s
of
[]
->
Nothing
(
C
_
c'
:
cs
)
|
c
==
c'
->
Just
(
cs
,
c
)
|
otherwise
->
Nothing
skipSpaces
::
P
()
skipSpaces
=
P
$
\
cs
->
Just
(
dropWhile
(
\
(
C
_
c
)
->
isSpace
c
)
cs
,
()
)
takeWhileMaybe
::
(
a
->
Maybe
b
)
->
[
a
]
->
([
b
],
[
a
])
takeWhileMaybe
f
=
go
where
go
xs0
@
[]
=
(
[]
,
xs0
)
go
xs0
@
(
x
:
xs
)
=
case
f
x
of
Just
y
->
let
(
ys
,
zs
)
=
go
xs
in
(
y
:
ys
,
zs
)
Nothing
->
(
[]
,
xs0
)
-------------------------------------------------------------------------------
-- Fields
-------------------------------------------------------------------------------
field
::
Int
->
P
(
String
,
String
)
field
i
=
do
fn
<-
munch1
$
\
_
c
->
isAlpha
c
||
c
==
'-'
skipSpaces
_
<-
char
':'
skipSpaces
val
<-
munch
$
\
j
c
->
isSpace
c
||
j
>
i
return
(
fn
,
val
)
fields
::
P
([(
String
,
String
)],
String
)
fields
=
do
skipSpaces
i
<-
curInd
fs
<-
many
(
field
i
)
r
<-
rest
return
(
fs
,
r
)
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment