Skip to content
体验新版
项目
组织
正在加载...
登录
切换导航
打开侧边栏
dotNET Platform
fsharp
提交
efa8c11c
F
fsharp
项目概览
dotNET Platform
/
fsharp
12 个月 前同步成功
通知
0
Star
1
Fork
0
代码
文件
提交
分支
Tags
贡献者
分支图
Diff
Issue
0
列表
看板
标记
里程碑
合并请求
0
DevOps
流水线
流水线任务
计划
Wiki
0
Wiki
分析
仓库
DevOps
项目成员
Pages
F
fsharp
项目概览
项目概览
详情
发布
仓库
仓库
文件
提交
分支
标签
贡献者
分支图
比较
Issue
0
Issue
0
列表
看板
标记
里程碑
合并请求
0
合并请求
0
Pages
DevOps
DevOps
流水线
流水线任务
计划
分析
分析
仓库分析
DevOps
Wiki
0
Wiki
成员
成员
收起侧边栏
关闭侧边栏
动态
分支图
创建新Issue
流水线任务
提交
Issue看板
体验新版 GitCode,发现更多精彩内容 >>
未验证
提交
efa8c11c
编写于
4月 01, 2022
作者:
D
Don Syme
提交者:
GitHub
4月 01, 2022
浏览文件
操作
浏览文件
下载
电子邮件补丁
差异文件
Don't emit XML doc for interface impls (#12918)
上级
5c4a76de
变更
13
隐藏空白更改
内联
并排
Showing
13 changed file
with
268 addition
and
143 deletion
+268
-143
src/fsharp/IlxGen.fs
src/fsharp/IlxGen.fs
+16
-42
src/fsharp/TypedTree.fs
src/fsharp/TypedTree.fs
+9
-0
src/fsharp/TypedTreeOps.fs
src/fsharp/TypedTreeOps.fs
+88
-53
src/fsharp/TypedTreeOps.fsi
src/fsharp/TypedTreeOps.fsi
+9
-6
src/fsharp/XmlDocFileWriter.fs
src/fsharp/XmlDocFileWriter.fs
+55
-24
src/fsharp/XmlDocFileWriter.fsi
src/fsharp/XmlDocFileWriter.fsi
+1
-1
src/fsharp/fsc.fs
src/fsharp/fsc.fs
+1
-1
tests/FSharp.Test.Utilities/TestFramework.fs
tests/FSharp.Test.Utilities/TestFramework.fs
+5
-5
tests/fsharp/TypeProviderTests.fs
tests/fsharp/TypeProviderTests.fs
+3
-3
tests/fsharp/core/xmldoc/lib.fs
tests/fsharp/core/xmldoc/lib.fs
+24
-0
tests/fsharp/core/xmldoc/lib.xml.bsl
tests/fsharp/core/xmldoc/lib.xml.bsl
+36
-0
tests/fsharp/single-test.fs
tests/fsharp/single-test.fs
+1
-1
tests/fsharp/tests.fs
tests/fsharp/tests.fs
+20
-7
未找到文件。
src/fsharp/IlxGen.fs
浏览文件 @
efa8c11c
...
...
@@ -6569,52 +6569,26 @@ and GenEventForProperty cenv eenvForMeth (mspec: ILMethodSpec) (v: Val) ilAttrsT
otherMethods
=
[]
,
customAttrs
=
mkILCustomAttrs
ilAttrsThatGoOnPrimaryItem
)
and
ComputeUseMethodImpl
cenv
(
v
:
Val
,
slotsig
:
SlotSig
)
=
let
oty
=
slotsig
.
ImplementedType
let
otcref
=
tcrefOfAppTy
cenv
.
g
oty
let
tcref
=
v
.
MemberApparentEntity
// REVIEW: it would be good to get rid of this special casing of Compare and GetHashCode during code generation
isInterfaceTy
cenv
.
g
oty
&&
(
let
isCompare
=
Option
.
isSome
tcref
.
GeneratedCompareToValues
&&
(
typeEquiv
cenv
.
g
oty
cenv
.
g
.
mk_IComparable_ty
||
tyconRefEq
cenv
.
g
cenv
.
g
.
system_GenericIComparable_tcref
otcref
)
not
isCompare
)
&&
(
let
isGenericEquals
=
Option
.
isSome
tcref
.
GeneratedHashAndEqualsWithComparerValues
&&
tyconRefEq
cenv
.
g
cenv
.
g
.
system_GenericIEquatable_tcref
otcref
not
isGenericEquals
)
&&
(
let
isStructural
=
(
Option
.
isSome
tcref
.
GeneratedCompareToWithComparerValues
&&
typeEquiv
cenv
.
g
oty
cenv
.
g
.
mk_IStructuralComparable_ty
)
||
(
Option
.
isSome
tcref
.
GeneratedHashAndEqualsWithComparerValues
&&
typeEquiv
cenv
.
g
oty
cenv
.
g
.
mk_IStructuralEquatable_ty
)
not
isStructural
)
and
ComputeMethodImplNameFixupForMemberBinding
cenv
(
v
:
Val
,
memberInfo
:
ValMemberInfo
)
=
if
isNil
memberInfo
.
ImplementedSlotSigs
then
and
ComputeMethodImplNameFixupForMemberBinding
cenv
(
v
:
Val
)
=
if
isNil
v
.
ImplementedSlotSigs
then
None
else
let
slotsig
=
memberInfo
.
ImplementedSlotSigs
|>
List
.
last
let
useMethodImpl
=
ComputeUseMethodImpl
cenv
(
v
,
slotsig
)
let
slotsig
=
v
.
ImplementedSlotSigs
|>
List
.
last
let
useMethodImpl
=
ComputeUseMethodImpl
cenv
.
g
v
let
nameOfOverridingMethod
=
GenNameOfOverridingMethod
cenv
(
useMethodImpl
,
slotsig
)
Some
nameOfOverridingMethod
and
ComputeFlagFixupsForMemberBinding
cenv
(
v
:
Val
,
memberInfo
:
ValMemberInfo
)
=
[
if
isNil
memberInfo
.
ImplementedSlotSigs
then
yield
fixupVirtualSlotFlags
and
ComputeFlagFixupsForMemberBinding
cenv
(
v
:
Val
)
=
[
let
useMethodImpl
=
ComputeUseMethodImpl
cenv
.
g
v
if
useMethodImpl
then
fixupMethodImplFlags
else
for
slotsig
in
memberInfo
.
ImplementedSlotSigs
do
let
useMethodImpl
=
ComputeUseMethodImpl
cenv
(
v
,
slotsig
)
fixupVirtualSlotFlags
if
useMethodImpl
then
yield
fixupMethodImplFlags
else
yield
fixupVirtualSlotFlags
match
ComputeMethodImplNameFixupForMemberBinding
cenv
(
v
,
memberInfo
)
with
|
Some
nm
->
yield
renameMethodDef
nm
|
None
->
()
]
match
ComputeMethodImplNameFixupForMemberBinding
cenv
v
with
|
Some
nm
->
renameMethodDef
nm
|
None
->
()
]
and
ComputeMethodImplAttribs
cenv
(_
v
:
Val
)
attrs
=
let
g
=
cenv
.
g
...
...
@@ -6805,10 +6779,10 @@ and GenMethodForBinding
((
memberInfo
.
MemberFlags
.
IsDispatchSlot
&&
memberInfo
.
IsImplemented
)
||
memberInfo
.
MemberFlags
.
IsOverrideOrExplicitImpl
)
then
let
useMethodImpl
=
memberInfo
.
ImplementedSlotSigs
|>
List
.
exists
(
fun
slotsig
->
ComputeUseMethodImpl
cenv
(
v
,
slotsig
))
let
useMethodImpl
=
ComputeUseMethodImpl
cenv
.
g
v
let
nameOfOverridingMethod
=
match
ComputeMethodImplNameFixupForMemberBinding
cenv
(
v
,
memberInfo
)
with
match
ComputeMethodImplNameFixupForMemberBinding
cenv
v
with
|
None
->
mspec
.
Name
|
Some
nm
->
nm
...
...
@@ -6853,7 +6827,7 @@ and GenMethodForBinding
elif
(
memberInfo
.
MemberFlags
.
IsDispatchSlot
&&
memberInfo
.
IsImplemented
)
||
memberInfo
.
MemberFlags
.
IsOverrideOrExplicitImpl
then
let
flagFixups
=
ComputeFlagFixupsForMemberBinding
cenv
(
v
,
memberInfo
)
let
flagFixups
=
ComputeFlagFixupsForMemberBinding
cenv
v
let
mdef
=
mkILGenericVirtualMethod
(
mspec
.
Name
,
ILMemberAccess
.
Public
,
ilMethTypars
,
ilParams
,
ilReturn
,
ilMethodBody
)
let
mdef
=
List
.
fold
(
fun
mdef
f
->
f
mdef
)
mdef
flagFixups
...
...
src/fsharp/TypedTree.fs
浏览文件 @
efa8c11c
...
...
@@ -2695,6 +2695,12 @@ type Val =
|
Some
memberInfo
when
memberInfo
.
MemberFlags
.
IsOverrideOrExplicitImpl
->
true
|
_
->
false
/// Gets the dispatch slots implemented by this method
member
x
.
ImplementedSlotSigs
=
match
x
.
MemberInfo
with
|
Some
memberInfo
->
memberInfo
.
ImplementedSlotSigs
|
_
->
[]
/// Indicates if this is declared 'mutable'
member
x
.
IsMutable
=
(
match
x
.
val_flags
.
MutabilityInfo
with
Immutable
->
false
|
Mutable
->
true
)
...
...
@@ -3799,6 +3805,9 @@ type ValRef =
/// Indicates if this value was a member declared 'override' or an implementation of an interface slot
member
x
.
IsOverrideOrExplicitImpl
=
x
.
Deref
.
IsOverrideOrExplicitImpl
/// Gets the dispatch slots implemented by this method
member
x
.
ImplementedSlotSigs
=
x
.
Deref
.
ImplementedSlotSigs
/// Is this a member, if so some more data about the member.
member
x
.
MemberInfo
=
x
.
Deref
.
MemberInfo
...
...
src/fsharp/TypedTreeOps.fs
浏览文件 @
efa8c11c
...
...
@@ -8478,14 +8478,14 @@ let rec typeEnc g (gtpsType, gtpsMethod) ty =
|
TType_measure
_
->
"?"
and
tyargsEnc
g
(
gtpsType
,
gtpsMethod
)
args
=
match
args
with
|
[]
->
""
|
[
a
]
when
(
match
(
stripTyEqns
g
a
)
with
TType_measure
_
->
true
|
_
->
false
)
->
""
// float<m> should appear as just "float" in the generated .XML xmldoc file
|
_
->
angleEnc
(
commaEncs
(
List
.
map
(
typeEnc
g
(
gtpsType
,
gtpsMethod
))
args
))
match
args
with
|
[]
->
""
|
[
a
]
when
(
match
(
stripTyEqns
g
a
)
with
TType_measure
_
->
true
|
_
->
false
)
->
""
// float<m> should appear as just "float" in the generated .XML xmldoc file
|
_
->
angleEnc
(
commaEncs
(
List
.
map
(
typeEnc
g
(
gtpsType
,
gtpsMethod
))
args
))
let
XmlDocArgsEnc
g
(
gtpsType
,
gtpsMethod
)
argTys
=
if
isNil
argTys
then
""
else
"("
+
String
.
concat
","
(
List
.
map
(
typeEnc
g
(
gtpsType
,
gtpsMethod
))
argTys
)
+
")"
if
isNil
argTys
then
""
else
"("
+
String
.
concat
","
(
List
.
map
(
typeEnc
g
(
gtpsType
,
gtpsMethod
))
argTys
)
+
")"
let
buildAccessPath
(
cp
:
CompilationPath
option
)
=
match
cp
with
...
...
@@ -8493,64 +8493,72 @@ let buildAccessPath (cp: CompilationPath option) =
let
ap
=
cp
.
AccessPath
|>
List
.
map
fst
|>
List
.
toArray
System
.
String
.
Join
(
"."
,
ap
)
|
None
->
"Extension Type"
let
prependPath
path
name
=
if
path
=
""
then
name
else
path
+
"."
+
name
let
XmlDocSigOfVal
g
full
path
(
v
:
Val
)
=
let
parentTypars
,
methTypars
,
cxs
,
argInfos
,
rty
,
prefix
,
path
,
name
=
let
parentTypars
,
methTypars
,
cxs
,
argInfos
,
rty
,
prefix
,
path
,
name
=
// CLEANUP: this is one of several code paths that treat module values and members
// separately when really it would be cleaner to make sure GetTopValTypeInFSharpForm, GetMemberTypeInFSharpForm etc.
// were lined up so code paths like this could be uniform
// CLEANUP: this is one of several code paths that treat module values and members
// separately when really it would be cleaner to make sure GetTopValTypeInFSharpForm, GetMemberTypeInFSharpForm etc.
// were lined up so code paths like this could be uniform
match
v
.
MemberInfo
with
|
Some
membInfo
when
not
v
.
IsExtensionMember
->
// Methods, Properties etc.
let
numEnclosingTypars
=
CountEnclosingTyparsOfActualParentOfVal
v
let
tps
,
witnessInfos
,
argInfos
,
rty
,
_
=
GetMemberTypeInMemberForm
g
membInfo
.
MemberFlags
(
Option
.
get
v
.
ValReprInfo
)
numEnclosingTypars
v
.
Type
v
.
Range
let
prefix
,
name
=
match
membInfo
.
MemberFlags
.
MemberKind
with
|
SynMemberKind
.
ClassConstructor
|
SynMemberKind
.
Constructor
->
"M:"
,
"#ctor"
|
SynMemberKind
.
Member
->
"M:"
,
v
.
CompiledName
g
.
CompilerGlobalState
|
SynMemberKind
.
PropertyGetSet
|
SynMemberKind
.
PropertySet
|
SynMemberKind
.
PropertyGet
->
"P:"
,
v
.
PropertyName
let
path
=
if
v
.
HasDeclaringEntity
then
prependPath
path
v
.
TopValDeclaringEntity
.
CompiledName
else
path
let
parentTypars
,
methTypars
=
match
PartitionValTypars
g
v
with
|
Some
(_,
memberParentTypars
,
memberMethodTypars
,
_,
_)
->
memberParentTypars
,
memberMethodTypars
|
None
->
[]
,
tps
parentTypars
,
methTypars
,
witnessInfos
,
argInfos
,
rty
,
prefix
,
path
,
name
|
_
->
// Regular F# values and extension members
let
w
=
arityOfVal
v
let
numEnclosingTypars
=
CountEnclosingTyparsOfActualParentOfVal
v
let
tps
,
witnessInfos
,
argInfos
,
rty
,
_
=
GetTopValTypeInCompiledForm
g
w
numEnclosingTypars
v
.
Type
v
.
Range
let
name
=
v
.
CompiledName
g
.
CompilerGlobalState
let
prefix
=
if
w
.
NumCurriedArgs
=
0
&&
isNil
tps
then
"P:"
else
"M:"
[]
,
tps
,
witnessInfos
,
argInfos
,
rty
,
prefix
,
path
,
name
let
witnessArgTys
=
GenWitnessTys
g
cxs
let
argTys
=
argInfos
|>
List
.
concat
|>
List
.
map
fst
let
argTys
=
witnessArgTys
@
argTys
@
(
match
rty
with
Some
t
when
full
->
[
t
]
|
_
->
[]
)
let
args
=
XmlDocArgsEnc
g
(
parentTypars
,
methTypars
)
argTys
let
arity
=
List
.
length
methTypars
in
(* C# XML doc adds ``<arity> to *generic* member names *)
let
genArity
=
if
arity
=
0
then
""
else
sprintf
"``%d"
arity
prefix
+
prependPath
path
name
+
genArity
+
args
match
v
.
MemberInfo
with
|
Some
membInfo
when
not
v
.
IsExtensionMember
->
// Methods, Properties etc.
let
numEnclosingTypars
=
CountEnclosingTyparsOfActualParentOfVal
v
let
tps
,
witnessInfos
,
argInfos
,
rty
,
_
=
GetMemberTypeInMemberForm
g
membInfo
.
MemberFlags
(
Option
.
get
v
.
ValReprInfo
)
numEnclosingTypars
v
.
Type
v
.
Range
let
prefix
,
name
=
match
membInfo
.
MemberFlags
.
MemberKind
with
|
SynMemberKind
.
ClassConstructor
|
SynMemberKind
.
Constructor
->
"M:"
,
"#ctor"
|
SynMemberKind
.
Member
->
"M:"
,
v
.
CompiledName
g
.
CompilerGlobalState
|
SynMemberKind
.
PropertyGetSet
|
SynMemberKind
.
PropertySet
|
SynMemberKind
.
PropertyGet
->
"P:"
,
v
.
PropertyName
let
path
=
if
v
.
HasDeclaringEntity
then
prependPath
path
v
.
TopValDeclaringEntity
.
CompiledName
else
path
let
parentTypars
,
methTypars
=
match
PartitionValTypars
g
v
with
|
Some
(_,
memberParentTypars
,
memberMethodTypars
,
_,
_)
->
memberParentTypars
,
memberMethodTypars
|
None
->
[]
,
tps
parentTypars
,
methTypars
,
witnessInfos
,
argInfos
,
rty
,
prefix
,
path
,
name
|
_
->
// Regular F# values and extension members
let
w
=
arityOfVal
v
let
numEnclosingTypars
=
CountEnclosingTyparsOfActualParentOfVal
v
let
tps
,
witnessInfos
,
argInfos
,
rty
,
_
=
GetTopValTypeInCompiledForm
g
w
numEnclosingTypars
v
.
Type
v
.
Range
let
name
=
v
.
CompiledName
g
.
CompilerGlobalState
let
prefix
=
if
w
.
NumCurriedArgs
=
0
&&
isNil
tps
then
"P:"
else
"M:"
[]
,
tps
,
witnessInfos
,
argInfos
,
rty
,
prefix
,
path
,
name
let
witnessArgTys
=
GenWitnessTys
g
cxs
let
argTys
=
argInfos
|>
List
.
concat
|>
List
.
map
fst
let
argTys
=
witnessArgTys
@
argTys
@
(
match
rty
with
Some
t
when
full
->
[
t
]
|
_
->
[]
)
let
args
=
XmlDocArgsEnc
g
(
parentTypars
,
methTypars
)
argTys
let
arity
=
List
.
length
methTypars
let
genArity
=
if
arity
=
0
then
""
else
sprintf
"``%d"
arity
prefix
+
prependPath
path
name
+
genArity
+
args
let
BuildXmlDocSig
prefix
path
s
=
prefix
+
List
.
fold
prependPath
""
paths
let
BuildXmlDocSig
prefix
path
=
prefix
+
List
.
fold
prependPath
""
path
let
XmlDocSigOfUnionCase
=
BuildXmlDocSig
"T:"
// Would like to use "U:", but ParseMemberSignature only accepts C# signatures
// Would like to use "U:", but ParseMemberSignature only accepts C# signatures
let
XmlDocSigOfUnionCase
path
=
BuildXmlDocSig
"T:"
path
let
XmlDocSigOfField
=
BuildXmlDocSig
"F:"
let
XmlDocSigOfField
path
=
BuildXmlDocSig
"F:"
path
let
XmlDocSigOfProperty
=
BuildXmlDocSig
"P:"
let
XmlDocSigOfProperty
path
=
BuildXmlDocSig
"P:"
path
let
XmlDocSigOfTycon
=
BuildXmlDocSig
"T:"
let
XmlDocSigOfTycon
path
=
BuildXmlDocSig
"T:"
path
let
XmlDocSigOfSubModul
=
BuildXmlDocSig
"T:"
let
XmlDocSigOfSubModul
path
=
BuildXmlDocSig
"T:"
path
let
XmlDocSigOfEntity
(
eref
:
EntityRef
)
=
XmlDocSigOfTycon
[(
buildAccessPath
eref
.
CompilationPathOpt
);
eref
.
Deref
.
CompiledName
]
...
...
@@ -9970,3 +9978,30 @@ let (|ResumableCodeInvoke|_|) g expr =
Some
(
iref
,
f
,
args
,
m
,
(
fun
(
f2
,
args2
)
->
Expr
.
App
((
iref
,
a
,
b
,
(
f2
::
args2
),
m
))))
|
_
->
None
let
ComputeUseMethodImpl
g
(
v
:
Val
)
=
v
.
ImplementedSlotSigs
|>
List
.
exists
(
fun
slotsig
->
let
oty
=
slotsig
.
ImplementedType
let
otcref
=
tcrefOfAppTy
g
oty
let
tcref
=
v
.
MemberApparentEntity
// REVIEW: it would be good to get rid of this special casing of Compare and GetHashCode
isInterfaceTy
g
oty
&&
(
let
isCompare
=
Option
.
isSome
tcref
.
GeneratedCompareToValues
&&
(
typeEquiv
g
oty
g
.
mk_IComparable_ty
||
tyconRefEq
g
g
.
system_GenericIComparable_tcref
otcref
)
not
isCompare
)
&&
(
let
isGenericEquals
=
Option
.
isSome
tcref
.
GeneratedHashAndEqualsWithComparerValues
&&
tyconRefEq
g
g
.
system_GenericIEquatable_tcref
otcref
not
isGenericEquals
)
&&
(
let
isStructural
=
(
Option
.
isSome
tcref
.
GeneratedCompareToWithComparerValues
&&
typeEquiv
g
oty
g
.
mk_IStructuralComparable_ty
)
||
(
Option
.
isSome
tcref
.
GeneratedHashAndEqualsWithComparerValues
&&
typeEquiv
g
oty
g
.
mk_IStructuralEquatable_ty
)
not
isStructural
))
src/fsharp/TypedTreeOps.fsi
浏览文件 @
efa8c11c
...
...
@@ -2281,17 +2281,17 @@ val XmlDocArgsEnc: TcGlobals -> Typars * Typars -> TType list -> string
val
XmlDocSigOfVal
:
TcGlobals
->
full
:
bool
->
string
->
Val
->
string
val
XmlDocSigOfUnionCase
:
(
string
list
->
string
)
val
XmlDocSigOfUnionCase
:
path
:
string
list
->
string
val
XmlDocSigOfField
:
(
string
list
->
string
)
val
XmlDocSigOfField
:
path
:
string
list
->
string
val
XmlDocSigOfProperty
:
(
string
list
->
string
)
val
XmlDocSigOfProperty
:
path
:
string
list
->
string
val
XmlDocSigOfTycon
:
(
string
list
->
string
)
val
XmlDocSigOfTycon
:
path
:
string
list
->
string
val
XmlDocSigOfSubModul
:
(
string
list
->
string
)
val
XmlDocSigOfSubModul
:
path
:
string
list
->
string
val
XmlDocSigOfEntity
:
EntityRef
->
string
val
XmlDocSigOfEntity
:
eref
:
EntityRef
->
string
//---------------------------------------------------------------------------
// Resolve static optimizations
...
...
@@ -2546,3 +2546,6 @@ val mkDebugPoint: m: range -> expr: Expr -> Expr
/// Match an if...then...else expression or the result of "a && b" or "a || b"
val
(|
IfThenElseExpr
|_|):
expr
:
Expr
->
(
Expr
*
Expr
*
Expr
)
option
/// Determine if a value is a method implementing an interface dispatch slot using a private method impl
val
ComputeUseMethodImpl
:
g
:
TcGlobals
->
v
:
Val
->
bool
\ No newline at end of file
src/fsharp/XmlDocFileWriter.fs
浏览文件 @
efa8c11c
...
...
@@ -18,87 +18,116 @@ module XmlDocWriter =
let
ComputeXmlDocSigs
(
tcGlobals
,
generatedCcu
:
CcuThunk
)
=
let
g
=
tcGlobals
let
doValSig
ptext
(
v
:
Val
)
=
if
hasDoc
v
.
XmlDoc
then
v
.
XmlDocSig
<-
XmlDocSigOfVal
g
false
ptext
v
let
doValSig
ptext
(
v
:
Val
)
=
if
hasDoc
v
.
XmlDoc
then
v
.
XmlDocSig
<-
XmlDocSigOfVal
g
false
ptext
v
let
doTyconSig
ptext
(
tc
:
Tycon
)
=
if
(
hasDoc
tc
.
XmlDoc
)
then
tc
.
XmlDocSig
<-
XmlDocSigOfTycon
[
ptext
;
tc
.
CompiledName
]
if
hasDoc
tc
.
XmlDoc
then
tc
.
XmlDocSig
<-
XmlDocSigOfTycon
[
ptext
;
tc
.
CompiledName
]
for
vref
in
tc
.
MembersOfFSharpTyconSorted
do
doValSig
ptext
vref
.
Deref
for
uc
in
tc
.
UnionCasesArray
do
if
(
hasDoc
uc
.
XmlDoc
)
then
if
hasDoc
uc
.
XmlDoc
then
uc
.
XmlDocSig
<-
XmlDocSigOfUnionCase
[
ptext
;
tc
.
CompiledName
;
uc
.
Id
.
idText
]
for
field
in
uc
.
RecdFieldsArray
do
if
(
hasDoc
field
.
XmlDoc
)
then
if
hasDoc
field
.
XmlDoc
then
// union case fields are exposed as properties
field
.
XmlDocSig
<-
XmlDocSigOfProperty
[
ptext
;
tc
.
CompiledName
;
uc
.
Id
.
idText
;
field
.
Id
.
idText
]
for
rf
in
tc
.
AllFieldsArray
do
if
(
hasDoc
rf
.
XmlDoc
)
then
if
hasDoc
rf
.
XmlDoc
then
rf
.
XmlDocSig
<-
if
tc
.
IsRecordTycon
&&
(
not
rf
.
IsStatic
)
then
if
tc
.
IsRecordTycon
&&
not
rf
.
IsStatic
then
// represents a record field, which is exposed as a property
XmlDocSigOfProperty
[
ptext
;
tc
.
CompiledName
;
rf
.
Id
.
idText
]
else
XmlDocSigOfField
[
ptext
;
tc
.
CompiledName
;
rf
.
Id
.
idText
]
let
doModuleMemberSig
path
(
m
:
ModuleOrNamespace
)
=
m
.
XmlDocSig
<-
XmlDocSigOfSubModul
[
path
]
(* moduleSpec - recurses *)
let
doModuleMemberSig
path
(
m
:
ModuleOrNamespace
)
=
m
.
XmlDocSig
<-
XmlDocSigOfSubModul
[
path
]
let
rec
doModuleSig
path
(
mspec
:
ModuleOrNamespace
)
=
let
mtype
=
mspec
.
ModuleOrNamespaceType
let
path
=
(* skip the first item in the path which is the assembly name *)
// skip the first item in the path which is the assembly name
match
path
with
|
None
->
Some
""
|
Some
""
->
Some
mspec
.
LogicalName
|
Some
p
->
Some
(
p
+
"."
+
mspec
.
LogicalName
)
let
ptext
=
match
path
with
None
->
""
|
Some
t
->
t
if
mspec
.
IsModule
then
doModuleMemberSig
ptext
mspec
let
ptext
=
defaultArg
path
""
if
mspec
.
IsModule
then
doModuleMemberSig
ptext
mspec
let
vals
=
mtype
.
AllValsAndMembers
|>
Seq
.
toList
|>
List
.
filter
(
fun
x
->
not
x
.
IsCompilerGenerated
)
|>
List
.
filter
(
fun
x
->
x
.
MemberInfo
.
IsNone
||
x
.
IsExtensionMember
)
List
.
iter
(
doModuleSig
path
)
mtype
.
ModuleAndNamespaceDefinitions
List
.
iter
(
doTyconSig
ptext
)
mtype
.
ExceptionDefinitions
List
.
iter
(
doValSig
ptext
)
vals
List
.
iter
(
doTyconSig
ptext
)
mtype
.
TypeDefinitions
mtype
.
ModuleAndNamespaceDefinitions
|>
List
.
iter
(
doModuleSig
path
)
mtype
.
ExceptionDefinitions
|>
List
.
iter
(
doTyconSig
ptext
)
vals
|>
List
.
iter
(
doValSig
ptext
)
mtype
.
TypeDefinitions
|>
List
.
iter
(
doTyconSig
ptext
)
doModuleSig
None
generatedCcu
.
Contents
let
WriteXmlDocFile
(
assemblyName
,
generatedCcu
:
CcuThunk
,
xmlfile
)
=
let
WriteXmlDocFile
(
g
,
assemblyName
,
generatedCcu
:
CcuThunk
,
xmlfile
)
=
if
not
(
FileSystemUtils
.
hasSuffixCaseInsensitive
"xml"
xmlfile
)
then
error
(
Error
(
FSComp
.
SR
.
docfileNoXmlSuffix
()
,
Range
.
rangeStartup
))
let
mutable
members
=
[]
let
addMember
id
xmlDoc
=
if
hasDoc
xmlDoc
then
let
doc
=
xmlDoc
.
GetXmlText
()
members
<-
(
id
,
doc
)
::
members
let
doVal
(
v
:
Val
)
=
addMember
v
.
XmlDocSig
v
.
XmlDoc
let
doField
(
rf
:
RecdField
)
=
addMember
rf
.
XmlDocSig
rf
.
XmlDoc
let
doVal
(
v
:
Val
)
=
addMember
v
.
XmlDocSig
v
.
XmlDoc
let
doField
(
rf
:
RecdField
)
=
addMember
rf
.
XmlDocSig
rf
.
XmlDoc
let
doUnionCase
(
uc
:
UnionCase
)
=
addMember
uc
.
XmlDocSig
uc
.
XmlDoc
for
field
in
uc
.
RecdFieldsArray
do
addMember
field
.
XmlDocSig
field
.
XmlDoc
let
doTycon
(
tc
:
Tycon
)
=
addMember
tc
.
XmlDocSig
tc
.
XmlDoc
for
vref
in
tc
.
MembersOfFSharpTyconSorted
do
doVal
vref
.
Deref
if
not
(
ComputeUseMethodImpl
g
vref
.
Deref
)
then
doVal
vref
.
Deref
for
uc
in
tc
.
UnionCasesArray
do
doUnionCase
uc
for
rf
in
tc
.
AllFieldsArray
do
doField
rf
let
modulMember
(
m
:
ModuleOrNamespace
)
=
addMember
m
.
XmlDocSig
m
.
XmlDoc
let
modulMember
(
m
:
ModuleOrNamespace
)
=
addMember
m
.
XmlDocSig
m
.
XmlDoc
let
rec
doModule
(
mspec
:
ModuleOrNamespace
)
=
let
mtype
=
mspec
.
ModuleOrNamespaceType
if
mspec
.
IsModule
then
modulMember
mspec
if
mspec
.
IsModule
then
modulMember
mspec
let
vals
=
mtype
.
AllValsAndMembers
|>
Seq
.
toList
|>
List
.
filter
(
fun
x
->
not
x
.
IsCompilerGenerated
)
|>
List
.
filter
(
fun
x
->
x
.
MemberInfo
.
IsNone
||
x
.
IsExtensionMember
)
List
.
iter
doModule
mtype
.
ModuleAndNamespaceDefinitions
List
.
iter
doTycon
mtype
.
ExceptionDefinitions
List
.
iter
doVal
vals
...
...
@@ -112,9 +141,11 @@ module XmlDocWriter =
fprintfn
os
"<doc>"
fprintfn
os
"<assembly><name>%s</name></assembly>"
assemblyName
fprintfn
os
"<members>"
members
|>
List
.
iter
(
fun
(
id
,
doc
)
->
fprintfn
os
"<member name=
\"
%s
\"
>"
id
for
(
nm
,
doc
)
in
members
do
fprintfn
os
"<member name=
\"
%s
\"
>"
nm
fprintfn
os
"%s"
doc
fprintfn
os
"</member>"
)
fprintfn
os
"</member>"
fprintfn
os
"</members>"
fprintfn
os
"</doc>"
src/fsharp/XmlDocFileWriter.fsi
浏览文件 @
efa8c11c
...
...
@@ -15,4 +15,4 @@ module XmlDocWriter =
/// Writes the XmlDocSig property of each element (field, union case, etc)
/// of the specified compilation unit to an XML document in a new text file.
val
WriteXmlDocFile
:
assemblyName
:
string
*
generatedCcu
:
CcuThunk
*
xmlfile
:
string
->
unit
val
WriteXmlDocFile
:
g
:
TcGlobals
*
assemblyName
:
string
*
generatedCcu
:
CcuThunk
*
xmlfile
:
string
->
unit
src/fsharp/fsc.fs
浏览文件 @
efa8c11c
...
...
@@ -757,7 +757,7 @@ let main2(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener
ReportTime
tcConfig
"Write XML docs"
tcConfig
.
xmlDocOutputFile
|>
Option
.
iter
(
fun
xmlFile
->
let
xmlFile
=
tcConfig
.
MakePathAbsolute
xmlFile
XmlDocWriter
.
WriteXmlDocFile
(
assemblyName
,
generatedCcu
,
xmlFile
))
XmlDocWriter
.
WriteXmlDocFile
(
tcGlobals
,
assemblyName
,
generatedCcu
,
xmlFile
))
// Pass on only the minimum information required for the next phase
Args
(
ctok
,
tcConfig
,
tcImports
,
frameworkTcImports
,
tcGlobals
,
errorLogger
,
generatedCcu
,
outfile
,
typedImplFiles
,
topAttrs
,
pdbfile
,
assemblyName
,
assemVerFromAttrib
,
signingInfo
,
exiter
)
...
...
tests/FSharp.Test.Utilities/TestFramework.fs
浏览文件 @
efa8c11c
...
...
@@ -113,7 +113,7 @@ module Commands =
let
directoryExists
workDir
path
=
if
path
|>
getfullpath
workDir
|>
Directory
.
Exists
then
Some
path
else
None
let
copy
_y
workDir
source
dest
=
let
copy
workDir
source
dest
=
log
"copy /y %s %s"
source
dest
File
.
Copy
(
source
|>
getfullpath
workDir
,
dest
|>
getfullpath
workDir
,
true
)
CmdResult
.
Success
...
...
@@ -619,16 +619,16 @@ let fsiAnyCpu cfg = Printf.ksprintf (Commands.fsi (exec cfg) cfg.FSIANYCPU)
let
fsi_script
cfg
=
Printf
.
ksprintf
(
Commands
.
fsi
(
exec
cfg
)
cfg
.
FSI_FOR_SCRIPTS
)
let
fsiExpectFail
cfg
=
Printf
.
ksprintf
(
Commands
.
fsi
(
execExpectFail
cfg
)
cfg
.
FSI
)
let
fsiAppendIgnoreExitCode
cfg
stdoutPath
stderrPath
=
Printf
.
ksprintf
(
Commands
.
fsi
(
execAppendIgnoreExitCode
cfg
stdoutPath
stderrPath
)
cfg
.
FSI
)
let
fileguard
cfg
=
(
Commands
.
getfullpath
cfg
.
Directory
)
>
>
(
fun
x
->
new
FileGuard
(
x
))
let
fileguard
cfg
fileName
=
Commands
.
getfullpath
cfg
.
Directory
fileName
|
>
(
fun
x
->
new
FileGuard
(
x
))
let
getfullpath
cfg
=
Commands
.
getfullpath
cfg
.
Directory
let
fileExists
cfg
=
Commands
.
fileExists
cfg
.
Directory
>
>
Option
.
isSome
let
fileExists
cfg
fileName
=
Commands
.
fileExists
cfg
.
Directory
fileName
|
>
Option
.
isSome
let
fsiStdin
cfg
stdinPath
=
Printf
.
ksprintf
(
Commands
.
fsi
(
execStdin
cfg
stdinPath
)
cfg
.
FSI
)
let
fsiStdinAppendBothIgnoreExitCode
cfg
stdoutPath
stderrPath
stdinPath
=
Printf
.
ksprintf
(
Commands
.
fsi
(
execStdinAppendBothIgnoreExitCode
cfg
stdoutPath
stderrPath
stdinPath
)
cfg
.
FSI
)
let
rm
cfg
x
=
Commands
.
rm
cfg
.
Directory
x
let
rmdir
cfg
x
=
Commands
.
rmdir
cfg
.
Directory
x
let
mkdir
cfg
=
Commands
.
mkdir_p
cfg
.
Directory
let
copy
_y
cfg
f
=
Commands
.
copy_y
cfg
.
Directory
f
>
>
checkResult
let
copySystemValueTuple
cfg
=
copy
_y
cfg
(
getDirectoryName
(
cfg
.
FSC
)
++
"System.ValueTuple.dll"
)
(
"."
++
"System.ValueTuple.dll"
)
let
copy
cfg
fromFile
toFile
=
Commands
.
copy
cfg
.
Directory
fromFile
toFile
|
>
checkResult
let
copySystemValueTuple
cfg
=
copy
cfg
(
getDirectoryName
(
cfg
.
FSC
)
++
"System.ValueTuple.dll"
)
(
"."
++
"System.ValueTuple.dll"
)
let
diff
normalize
path1
path2
=
let
result
=
System
.
Text
.
StringBuilder
()
...
...
tests/fsharp/TypeProviderTests.fs
浏览文件 @
efa8c11c
...
...
@@ -116,7 +116,7 @@ let helloWorld p =
let
bincompat1
=
getfullpath
cfg
"bincompat1"
Directory
.
EnumerateFiles
(
bincompat1
++
".."
,
"*.dll"
)
|>
Seq
.
iter
(
fun
from
->
Commands
.
copy
_y
bincompat1
from
(
"."
++
Path
.
GetFileName
(
from
))
|>
ignore
)
|>
Seq
.
iter
(
fun
from
->
Commands
.
copy
bincompat1
from
(
"."
++
Path
.
GetFileName
(
from
))
|>
ignore
)
fscIn
cfg
bincompat1
"%s"
"-g -a -o:test_lib.dll -r:provider.dll"
[
".."
++
"test.fsx"
]
...
...
@@ -129,8 +129,8 @@ let helloWorld p =
log
"pushd bincompat2"
let
bincompat2
=
getfullpath
cfg
"bincompat2"
Directory
.
EnumerateFiles
(
bincompat2
++
".."
++
"bincompat1"
,
"*.dll"
)
|>
Seq
.
iter
(
fun
from
->
Commands
.
copy_y
bincompat2
from
(
"."
++
Path
.
GetFileName
(
from
))
|>
ignore
)
for
fromFile
in
Directory
.
EnumerateFiles
(
bincompat2
++
".."
++
"bincompat1"
,
"*.dll"
)
do
Commands
.
copy
bincompat2
fromFile
(
"."
++
Path
.
GetFileName
(
fromFile
))
|>
ignore
fscIn
cfg
bincompat2
"%s"
"--define:ADD_AN_OPTIONAL_STATIC_PARAMETER --define:USE_IMPLICIT_ITypeProvider2 --out:provider.dll -g -a"
[
".."
++
"provider.fsx"
]
...
...
tests/fsharp/core/xmldoc/lib.fs
0 → 100644
浏览文件 @
efa8c11c
namespace
XmlDoc
open
System
.
Collections
open
System
.
Collections
.
Generic
type
InterfaceImpl
()
=
interface
IEnumerable
with
/// This should not appear
member
this
.
GetEnumerator
()
=
failwith
""
/// Simple type
type
SimpleType
/// Simple constructor
()
=
/// Simple getter property
member
this
.
P
=
1
/// Simple setter property
member
this
.
SetterProperty
with
get
()
=
1
and
set
(
v
:
int
)
=
()
/// Simple method
member
this
.
M
()
=
1
tests/fsharp/core/xmldoc/lib.xml.bsl
0 → 100644
浏览文件 @
efa8c11c
<?
xml
version
=
"1.0"
encoding
=
"utf-8"
?>
<
doc
>
<
assembly
><
name
>
lib
</
name
></
assembly
>
<
members
>
<
member
name
=
"P:XmlDoc.SimpleType.SetterProperty(System.Int32)"
>
<
summary
>
Simple
setter
property
</
summary
>
</
member
>
<
member
name
=
"P:XmlDoc.SimpleType.SetterProperty"
>
<
summary
>
Simple
setter
property
</
summary
>
</
member
>
<
member
name
=
"P:XmlDoc.SimpleType.P"
>
<
summary
>
Simple
getter
property
</
summary
>
</
member
>
<
member
name
=
"M:XmlDoc.SimpleType.M"
>
<
summary
>
Simple
method
</
summary
>
</
member
>
<
member
name
=
"M:XmlDoc.SimpleType.#ctor"
>
<
summary
>
Simple
constructor
</
summary
>
</
member
>
<
member
name
=
"T:XmlDoc.SimpleType"
>
<
summary
>
Simple
type
</
summary
>
</
member
>
</
members
>
</
doc
>
tests/fsharp/single-test.fs
浏览文件 @
efa8c11c
...
...
@@ -327,7 +327,7 @@ let singleTestBuildAndRunCore cfg copyFiles p languageVersion =
|>
List
.
rev
|>
List
.
tryFind
(
fileExists
cfg
)
source1
|>
Option
.
iter
(
fun
from
->
copy
_y
cfg
from
"tmptest.fs"
)
source1
|>
Option
.
iter
(
fun
from
->
copy
cfg
from
"tmptest.fs"
)
log
"Generated signature file..."
fsc
cfg
"%s --sig:tmptest.fsi --define:FSC_NETFX_TEST_GENERATED_SIGNATURE"
cfg
.
fsc_flags
[
"tmptest.fs"
]
...
...
tests/fsharp/tests.fs
浏览文件 @
efa8c11c
...
...
@@ -819,9 +819,9 @@ module CoreTests =
csc
cfg
"""/nologo /target:library /r:split
\
a-part1.dll /out:split
\
a.dll /define:PART2;SPLIT"""
[
"a.cs"
]
copy
_y
cfg
(
"orig"
++
"b.dll"
)
(
"split"
++
"b.dll"
)
copy
cfg
(
"orig"
++
"b.dll"
)
(
"split"
++
"b.dll"
)
copy
_y
cfg
(
"orig"
++
"c.dll"
)
(
"split"
++
"c.dll"
)
copy
cfg
(
"orig"
++
"c.dll"
)
(
"split"
++
"c.dll"
)
fsc
cfg
"""-o:orig
\t
est.exe -r:orig
\b
.dll -r:orig
\
a.dll"""
[
"test.fs"
]
...
...
@@ -835,6 +835,22 @@ module CoreTests =
peverify
cfg
(
"split"
++
"c.dll"
)
[<
Test
>]
let
xmldoc
()
=
let
cfg
=
testConfig
"core/xmldoc"
fsc
cfg
"%s -a --doc:lib.xml -o:lib.dll -g"
cfg
.
fsc_flags
[
"lib.fs"
]
let
outFile
=
"lib.xml"
let
expectedFile
=
"lib.xml.bsl"
if
not
(
fileExists
cfg
expectedFile
)
then
copy
cfg
outFile
expectedFile
let
diffs
=
fsdiff
cfg
outFile
expectedFile
match
diffs
with
|
""
->
()
|
_
->
Assert
.
Fail
(
sprintf
"'%s' and '%s' differ; %A"
outFile
expectedFile
diffs
)
[<
Test
>]
let
fsfromcs
()
=
let
cfg
=
testConfig
"core/fsfromcs"
...
...
@@ -1036,8 +1052,6 @@ module CoreTests =
if
requireENCulture
()
then
let
copy
from'
=
Commands
.
copy_y
cfg
.
Directory
from'
>>
checkResult
let
``fsi <a >b 2>c``
=
// "%FSI%" %fsc_flags_errors_ok% --nologo <test.fsx >z.raw.output.test.default.txt 2>&1
let
``exec <a >b 2>c``
(
inFile
,
outFile
,
errFile
)
p
=
...
...
@@ -1059,13 +1073,12 @@ module CoreTests =
removeCDandHelp
rawFileOut
diffFileOut
removeCDandHelp
rawFileErr
diffFileErr
let
withDefault
default
'
to'
=
if
not
(
fileExists
cfg
to
'
)
then
copy
default'
to'
let
withDefault
default
File
toFile
=
if
not
(
fileExists
cfg
to
File
)
then
copy
cfg
defaultFile
toFile
expectedFileOut
|>
withDefault
diffFileOut
expectedFileErr
|>
withDefault
diffFileErr
match
fsdiff
cfg
diffFileOut
expectedFileOut
with
|
""
->
()
|
diffs
->
Assert
.
Fail
(
sprintf
"'%s' and '%s' differ; %A"
diffFileOut
expectedFileOut
diffs
)
...
...
编辑
预览
Markdown
is supported
0%
请重试
或
添加新附件
.
添加附件
取消
You are about to add
0
people
to the discussion. Proceed with caution.
先完成此消息的编辑!
取消
想要评论请
注册
或
登录