Skip to content

Commit

Permalink
Merge pull request #1132 from dsyme/mutrec
Browse files Browse the repository at this point in the history 
RFC FS-1009 - optionally declare mutually referential types and modules over larger scopes within files

Thanks for taking care of this Don.
  • Loading branch information
@KevinRansom
KevinRansom committed Jun 15, 2016
2 parents 830a1d4 + 373f0bb commit 7ff92d4
Show file tree
Hide file tree
Showing 41 changed files with 9,706 additions and 1,743 deletions.
56 changes: 28 additions & 28 deletions src/fsharp/CompileOps.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3191,17 +3191,17 @@ let ComputeQualifiedNameOfFileFromUniquePath (m, p: string list) = QualifiedName

let QualFileNameOfSpecs filename specs =
match specs with
| [SynModuleOrNamespaceSig(modname,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname
| [SynModuleOrNamespaceSig(modname,_,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname
| _ -> QualFileNameOfFilename (rangeN filename 1) filename

let QualFileNameOfImpls filename specs =
match specs with
| [SynModuleOrNamespace(modname,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname
| [SynModuleOrNamespace(modname,_,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname
| _ -> QualFileNameOfFilename (rangeN filename 1) filename

let PrepandPathToQualFileName x (QualifiedNameOfFile(q)) = ComputeQualifiedNameOfFileFromUniquePath (q.idRange,pathOfLid x@[q.idText])
let PrepandPathToImpl x (SynModuleOrNamespace(p,c,d,e,f,g,h)) = SynModuleOrNamespace(x@p,c,d,e,f,g,h)
let PrepandPathToSpec x (SynModuleOrNamespaceSig(p,c,d,e,f,g,h)) = SynModuleOrNamespaceSig(x@p,c,d,e,f,g,h)
let PrepandPathToImpl x (SynModuleOrNamespace(p,b,c,d,e,f,g,h)) = SynModuleOrNamespace(x@p,b,c,d,e,f,g,h)
let PrepandPathToSpec x (SynModuleOrNamespaceSig(p,b,c,d,e,f,g,h)) = SynModuleOrNamespaceSig(x@p,b,c,d,e,f,g,h)

let PrependPathToInput x inp =
match inp with
Expand All @@ -3225,13 +3225,13 @@ let ComputeAnonModuleName check defaultNamespace filename (m: range) =

let PostParseModuleImpl (_i,defaultNamespace,isLastCompiland,filename,impl) =
match impl with
| ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,isModule,decls,xmlDoc,attribs,access,m)) ->
| ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) ->
let lid =
match lid with
| [id] when isModule && id.idText = MangledGlobalName -> error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(),id.idRange))
| id :: rest when id.idText = MangledGlobalName -> rest
| _ -> lid
SynModuleOrNamespace(lid,isModule,decls,xmlDoc,attribs,access,m)
SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)

| ParsedImplFileFragment.AnonModule (defs,m)->
let isLast, isExe = isLastCompiland
Expand All @@ -3242,24 +3242,24 @@ let PostParseModuleImpl (_i,defaultNamespace,isLastCompiland,filename,impl) =
| _ -> errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(),trimRangeToLine m))

let modname = ComputeAnonModuleName (nonNil defs) defaultNamespace filename (trimRangeToLine m)
SynModuleOrNamespace(modname,true,defs,PreXmlDoc.Empty,[],None,m)
SynModuleOrNamespace(modname,false,true,defs,PreXmlDoc.Empty,[],None,m)

| ParsedImplFileFragment.NamespaceFragment (lid,b,c,d,e,m)->
| ParsedImplFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)->
let lid =
match lid with
| id :: rest when id.idText = MangledGlobalName -> rest
| _ -> lid
SynModuleOrNamespace(lid,b,c,d,e,None,m)
SynModuleOrNamespace(lid,a,b,c,d,e,None,m)

let PostParseModuleSpec (_i,defaultNamespace,isLastCompiland,filename,intf) =
match intf with
| ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,isModule,decls,xmlDoc,attribs,access,m)) ->
| ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) ->
let lid =
match lid with
| [id] when isModule && id.idText = MangledGlobalName -> error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(),id.idRange))
| id :: rest when id.idText = MangledGlobalName -> rest
| _ -> lid
SynModuleOrNamespaceSig(lid,isModule,decls,xmlDoc,attribs,access,m)
SynModuleOrNamespaceSig(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)

| ParsedSigFileFragment.AnonModule (defs,m) ->
let isLast, isExe = isLastCompiland
Expand All @@ -3270,19 +3270,19 @@ let PostParseModuleSpec (_i,defaultNamespace,isLastCompiland,filename,intf) =
| _ -> errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(),m))

let modname = ComputeAnonModuleName (nonNil defs) defaultNamespace filename (trimRangeToLine m)
SynModuleOrNamespaceSig(modname,true,defs,PreXmlDoc.Empty,[],None,m)
SynModuleOrNamespaceSig(modname,false,true,defs,PreXmlDoc.Empty,[],None,m)

| ParsedSigFileFragment.NamespaceFragment (lid,b,c,d,e,m)->
| ParsedSigFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)->
let lid =
match lid with
| id :: rest when id.idText = MangledGlobalName -> rest
| _ -> lid
SynModuleOrNamespaceSig(lid,b,c,d,e,None,m)
SynModuleOrNamespaceSig(lid,a,b,c,d,e,None,m)



let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFile(hashDirectives,impls)) =
match impls |> List.rev |> List.tryPick (function ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with
match impls |> List.rev |> List.tryPick (function ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,_,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with
| Some lid when impls.Length > 1 ->
errorR(Error(FSComp.SR.buildMultipleToplevelModules(),rangeOfLid lid))
| _ ->
Expand All @@ -3292,7 +3292,7 @@ let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFi
let isScript = IsScript filename

let scopedPragmas =
[ for (SynModuleOrNamespace(_,_,decls,_,_,_,_)) in impls do
[ for (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) in impls do
for d in decls do
match d with
| SynModuleDecl.HashDirective (hd,_) -> yield! GetScopedPragmasForHashDirective hd
Expand All @@ -3302,7 +3302,7 @@ let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFi
ParsedInput.ImplFile(ParsedImplFileInput(filename,isScript,qualName,scopedPragmas,hashDirectives,impls,isLastCompiland))

let PostParseModuleSpecs (defaultNamespace,filename,isLastCompiland,ParsedSigFile(hashDirectives,specs)) =
match specs |> List.rev |> List.tryPick (function ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with
match specs |> List.rev |> List.tryPick (function ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,_,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with
| Some lid when specs.Length > 1 ->
errorR(Error(FSComp.SR.buildMultipleToplevelModules(),rangeOfLid lid))
| _ ->
Expand All @@ -3311,7 +3311,7 @@ let PostParseModuleSpecs (defaultNamespace,filename,isLastCompiland,ParsedSigFil
let specs = specs |> List.mapi (fun i x -> PostParseModuleSpec(i,defaultNamespace,isLastCompiland,filename,x))
let qualName = QualFileNameOfSpecs filename specs
let scopedPragmas =
[ for (SynModuleOrNamespaceSig(_,_,decls,_,_,_,_)) in specs do
[ for (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) in specs do
for d in decls do
match d with
| SynModuleSigDecl.HashDirective(hd,_) -> yield! GetScopedPragmasForHashDirective hd
Expand Down Expand Up @@ -3390,12 +3390,12 @@ let ParseOneInputLexbuf (tcConfig:TcConfig,lexResourceManager,conditionalCompila

if tcConfig.reportNumDecls then
let rec flattenSpecs specs =
specs |> List.collect (function (SynModuleSigDecl.NestedModule (_,subDecls,_)) -> flattenSpecs subDecls | spec -> [spec])
specs |> List.collect (function (SynModuleSigDecl.NestedModule (_,_,subDecls,_)) -> flattenSpecs subDecls | spec -> [spec])
let rec flattenDefns specs =
specs |> List.collect (function (SynModuleDecl.NestedModule (_,subDecls,_,_)) -> flattenDefns subDecls | defn -> [defn])
specs |> List.collect (function (SynModuleDecl.NestedModule (_,_,subDecls,_,_)) -> flattenDefns subDecls | defn -> [defn])

let flattenModSpec (SynModuleOrNamespaceSig(_,_,decls,_,_,_,_)) = flattenSpecs decls
let flattenModImpl (SynModuleOrNamespace(_,_,decls,_,_,_,_)) = flattenDefns decls
let flattenModSpec (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) = flattenSpecs decls
let flattenModImpl (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) = flattenDefns decls
match res with
| ParsedInput.SigFile(ParsedSigFileInput(_,_,_,_,specs)) ->
dprintf "parsing yielded %d specs" (List.collect flattenModSpec specs).Length
Expand Down Expand Up @@ -4723,30 +4723,30 @@ let ProcessMetaCommandsFromInput
decls |> List.iter (fun d ->
match d with
| SynModuleSigDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m))
| SynModuleSigDecl.NestedModule (_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls
| SynModuleSigDecl.NestedModule (_,_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls
| _ -> ())

let rec WarnOnIgnoredImplDecls decls =
decls |> List.iter (fun d ->
match d with
| SynModuleDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m))
| SynModuleDecl.NestedModule (_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls
| SynModuleDecl.NestedModule (_,_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls
| _ -> ())

let ProcessMetaCommandsFromModuleSpec state (SynModuleOrNamespaceSig(_,_,decls,_,_,_,_)) =
let ProcessMetaCommandsFromModuleSpec state (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) =
List.fold (fun s d ->
match d with
| SynModuleSigDecl.HashDirective (h,_) -> ProcessMetaCommand s h
| SynModuleSigDecl.NestedModule (_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls; s
| SynModuleSigDecl.NestedModule (_,_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls; s
| _ -> s)
state
decls

let ProcessMetaCommandsFromModuleImpl state (SynModuleOrNamespace(_,_,decls,_,_,_,_)) =
let ProcessMetaCommandsFromModuleImpl state (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) =
List.fold (fun s d ->
match d with
| SynModuleDecl.HashDirective (h,_) -> ProcessMetaCommand s h
| SynModuleDecl.NestedModule (_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls; s
| SynModuleDecl.NestedModule (_,_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls; s
| _ -> s)
state
decls
Expand Down
9 changes: 7 additions & 2 deletions src/fsharp/FSComp.txt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -693,7 +693,7 @@ tcUnnamedArgumentsDoNotFormPrefix,"The unnamed arguments do not form a prefix of
871,tcConstructorsIllegalForThisType,"Constructors cannot be defined for this type"
872,tcRecursiveBindingsWithMembersMustBeDirectAugmentation,"Recursive bindings that include member specifications can only occur as a direct augmentation of a type"
873,tcOnlySimplePatternsInLetRec,"Only simple variable patterns can be bound in 'let rec' constructs"
874,tcOnlyRecordFieldsAndSimpleLetCanBeMutable,"Only record fields and simple 'let' bindings may be marked mutable"
874,tcOnlyRecordFieldsAndSimpleLetCanBeMutable,"Only record fields and simple, non-recursive 'let' bindings may be marked mutable"
875,tcMemberIsNotSufficientlyGeneric,"This member is not sufficiently generic"
876,tcLiteralAttributeRequiresConstantValue,"A declaration may only be the [<Literal>] attribute if a constant value is also given, e.g. 'val x : int = 1'"
877,tcValueInSignatureRequiresLiteralAttribute,"A declaration may only be given a value in a signature if the declaration has the [<Literal>] attribute"
Expand Down Expand Up @@ -1301,4 +1301,9 @@ estApplyStaticArgumentsForMethodNotImplemented,"A type provider implemented GetS
3196,fsharpCoreNotFoundToBeCopied,"Cannot find FSharp.Core.dll in compiler's directory"
3197,etMissingStaticArgumentsToMethod,"This provided method requires static parameters"
3198,considerUpcast,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using 'upcast' instead of 'downcast'."
3198,considerUpcastOperator,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using the :> (upcast) operator instead of the :?> (downcast) operator."
3198,considerUpcastOperator,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using the :> (upcast) operator instead of the :?> (downcast) operator."
3199,tcRecImplied,"The 'rec' on this module is implied by an outer 'rec' declaration and is being ignored"
3200,tcOpenFirstInMutRec,"In a recursive declaration group, 'open' declarations must come first in each module"
3201,tcModuleAbbrevFirstInMutRec,"In a recursive declaration group, module abbreviations must come after all 'open' declarations and before other declarations"
3202,tcUnsupportedMutRecDecl,"This declaration is not supported in recursive declaration groups"
3203,parsInvalidUseOfRec,"Invalid use of 'rec' keyword"
8 changes: 5 additions & 3 deletions src/fsharp/FindUnsolved.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -231,16 +231,18 @@ and accModuleOrNamespaceDefs cenv env x = List.iter (accModuleOrNamespaceDef cen

and accModuleOrNamespaceDef cenv env x =
match x with
| TMDefRec(tycons,binds,mbinds,_m) ->
| TMDefRec(_,tycons,mbinds,_m) ->
accTycons cenv env tycons;
accBinds cenv env binds;
accModuleOrNamespaceBinds cenv env mbinds
| TMDefLet(bind,_m) -> accBind cenv env bind
| TMDefDo(e,_m) -> accExpr cenv env e
| TMAbstract(def) -> accModuleOrNamespaceExpr cenv env def
| TMDefs(defs) -> accModuleOrNamespaceDefs cenv env defs
and accModuleOrNamespaceBinds cenv env xs = List.iter (accModuleOrNamespaceBind cenv env) xs
and accModuleOrNamespaceBind cenv env (ModuleOrNamespaceBinding(mspec, rhs)) = accTycon cenv env mspec; accModuleOrNamespaceDef cenv env rhs
and accModuleOrNamespaceBind cenv env x =
match x with
| ModuleOrNamespaceBinding.Binding bind -> accBind cenv env bind
| ModuleOrNamespaceBinding.Module(mspec, rhs) -> accTycon cenv env mspec; accModuleOrNamespaceDef cenv env rhs

let UnsolvedTyparsOfModuleDef g amap denv (mdef, extraAttribs) =
let cenv =
Expand Down
32 changes: 19 additions & 13 deletions src/fsharp/IlxGen.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -964,11 +964,10 @@ let rec AddBindingsForModuleDefs allocVal (cloc:CompileLocation) eenv mdefs =

and AddBindingsForModuleDef allocVal cloc eenv x =
match x with
| TMDefRec(tycons,vbinds,mbinds,_) ->
let eenv = FlatList.foldBack (allocVal cloc) (valsOfBinds vbinds) eenv
| TMDefRec(_isRec,tycons,mbinds,_) ->
(* Virtual don't have 'let' bindings and must be added to the environment *)
let eenv = List.foldBack (AddBindingsForTycon allocVal cloc) tycons eenv
let eenv = List.foldBack (AddBindingsForSubModules allocVal cloc) mbinds eenv
let eenv = List.foldBack (AddBindingsForModule allocVal cloc) mbinds eenv
eenv
| TMDefLet(bind,_) ->
allocVal cloc bind.Var eenv
Expand All @@ -979,12 +978,16 @@ and AddBindingsForModuleDef allocVal cloc eenv x =
| TMDefs(mdefs) ->
AddBindingsForModuleDefs allocVal cloc eenv mdefs

and AddBindingsForSubModules allocVal cloc (ModuleOrNamespaceBinding(mspec, mdef)) eenv =
let cloc =
if mspec.IsNamespace then cloc
else CompLocForFixedModule cloc.clocQualifiedNameOfFile cloc.clocTopImplQualifiedName mspec
and AddBindingsForModule allocVal cloc x eenv =
match x with
| ModuleOrNamespaceBinding.Binding bind ->
allocVal cloc bind.Var eenv
| ModuleOrNamespaceBinding.Module (mspec, mdef) ->
let cloc =
if mspec.IsNamespace then cloc
else CompLocForFixedModule cloc.clocQualifiedNameOfFile cloc.clocTopImplQualifiedName mspec

AddBindingsForModuleDef allocVal cloc eenv mdef
AddBindingsForModuleDef allocVal cloc eenv mdef

and AddBindingsForModuleTopVals _g allocVal _cloc eenv vs =
FlatList.foldBack allocVal vs eenv
Expand Down Expand Up @@ -5669,13 +5672,12 @@ and GenModuleDefs cenv cgbuf qname lazyInitInfo eenv mdefs =

and GenModuleDef cenv (cgbuf:CodeGenBuffer) qname lazyInitInfo eenv x =
match x with
| TMDefRec(tycons,binds,mbinds,m) ->
| TMDefRec(_isRec,tycons,mbinds,m) ->
tycons |> List.iter (fun tc ->
if tc.IsExceptionDecl
then GenExnDef cenv cgbuf.mgbuf eenv m tc
else GenTypeDef cenv cgbuf.mgbuf lazyInitInfo eenv m tc) ;
GenLetRecBinds cenv cgbuf eenv (binds,m);
mbinds |> List.iter (GenModuleBinding cenv cgbuf qname lazyInitInfo eenv)
else GenTypeDef cenv cgbuf.mgbuf lazyInitInfo eenv m tc)
mbinds |> List.iter (GenModuleBinding cenv cgbuf qname lazyInitInfo eenv m)

| TMDefLet(bind,_) ->
GenBindings cenv cgbuf eenv (FlatList.one bind)
Expand All @@ -5691,7 +5693,11 @@ and GenModuleDef cenv (cgbuf:CodeGenBuffer) qname lazyInitInfo eenv x =


// Generate a module binding
and GenModuleBinding cenv (cgbuf:CodeGenBuffer) (qname:QualifiedNameOfFile) lazyInitInfo eenv (ModuleOrNamespaceBinding (mspec, mdef)) =
and GenModuleBinding cenv (cgbuf:CodeGenBuffer) (qname:QualifiedNameOfFile) lazyInitInfo eenv m x =
match x with
| ModuleOrNamespaceBinding.Binding bind ->
GenLetRecBinds cenv cgbuf eenv ([bind],m);
| ModuleOrNamespaceBinding.Module (mspec, mdef) ->
let hidden = IsHiddenTycon eenv.sigToImplRemapInfo mspec

let eenvinner =
Expand Down
16 changes: 10 additions & 6 deletions src/fsharp/InnerLambdasToTopLevelFuncs.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1288,10 +1288,9 @@ module Pass4_RewriteAssembly =
and TransModuleDefs penv z x = List.mapFold (TransModuleDef penv) z x
and TransModuleDef penv (z: RewriteState) x : ModuleOrNamespaceExpr * RewriteState =
match x with
| TMDefRec(tycons,binds,mbinds,m) ->
let binds,z = TransValBindings penv z binds
| TMDefRec(isRec,tycons,mbinds,m) ->
let mbinds,z = TransModuleBindings penv z mbinds
TMDefRec(tycons,binds,mbinds,m),z
TMDefRec(isRec,tycons,mbinds,m),z
| TMDefLet(bind,m) ->
let bind,z = TransValBinding penv z bind
TMDefLet(bind,m),z
Expand All @@ -1305,9 +1304,14 @@ module Pass4_RewriteAssembly =
let mexpr,z = TransModuleExpr penv z mexpr
TMAbstract(mexpr),z
and TransModuleBindings penv z binds = List.mapFold (TransModuleBinding penv) z binds
and TransModuleBinding penv z (ModuleOrNamespaceBinding(nm, rhs)) =
let rhs,z = TransModuleDef penv z rhs
ModuleOrNamespaceBinding(nm,rhs),z
and TransModuleBinding penv z x =
match x with
| ModuleOrNamespaceBinding.Binding bind ->
let bind,z = TransValBinding penv z bind
ModuleOrNamespaceBinding.Binding bind,z
| ModuleOrNamespaceBinding.Module(nm, rhs) ->
let rhs,z = TransModuleDef penv z rhs
ModuleOrNamespaceBinding.Module(nm,rhs),z

let TransImplFile penv z (TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript)) =
let moduleExpr,z = TransModuleExpr penv z moduleExpr
Expand Down
Loading

0 comments on commit 7ff92d4

Please sign in to comment.