patrick/WoofWare.Myriad
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.Myriad synced 2025-10-31 08:38:59 +00:00
Code Issues Packages Projects Releases Wiki Activity

Fix one bit of bug

Browse Source
This commit is contained in:
Smaug123
2024-02-18 20:54:20 +00:00
parent d86bd743af
commit 030d8ffa12
2 changed files with 51 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
ConsumePlugin/GeneratedCatamorphism.fs
View File

@@ -21,7 +21,7 @@ type TreeBuilderCataCase<'a, 'TreeBuilder, 'Tree> =
/// Description of how to combine cases during a fold
type TreeCataCase<'a, 'TreeBuilder, 'Tree> =
/// How to operate on the Const case
abstract Const : Const -> 'Tree
abstract Const : Const<'a> -> 'Tree
/// How to operate on the Pair case
abstract Pair : 'Tree -> 'Tree -> PairOpKind -> 'Tree
/// How to operate on the Sequential case

64
WoofWare.Myriad.Plugins/CataGenerator.fs
View File

@@ -35,8 +35,10 @@ module internal CataGenerator =
/// The relationship this field has with the parent type (or the
/// recursive knot of parent types)
Description : FieldDescription
/// Any generic parameters this field consumes
RequiredGenerics : SynType list option
/// Any generic parameters this field consumes.
/// This only makes sense in the context of a UnionAnalysis:
/// it is an index into the parent Union's collection of generic parameters.
RequiredGenerics : int list option
}
type CataUnionRecordField = (Ident * CataUnionBasicField) list
@@ -303,14 +305,19 @@ module internal CataGenerator =
/// Get the fields of this particular union case, and describe their relation to the
/// recursive knot of user-provided DUs for which we are creating a cata.
let analyse
(availableGenerics : SynTyparDecl list)
(allRecordTypes : SynTypeDefn list)
(allUnionTypes : SynTypeDefn list)
(argIndex : int)
(fields : AdtNode list)
: CataUnionBasicField list
=
let availableGenerics =
availableGenerics
|> List.map (fun (SynTyparDecl.SynTyparDecl (_, SynTypar.SynTypar (ident, _, _))) -> ident)
let rec go (prefix : string) (name : Ident option) (ty : SynType) : CataUnionBasicField =
let dealWithPrimitive (typeArgs : SynType list option) (ty : SynType) (typeName : LongIdent) =
let dealWithPrimitive (typeArgs : int list option) (ty : SynType) (typeName : LongIdent) =
let key = typeName |> List.map _.idText |> String.concat "/"
let isKnownUnion =
@@ -341,7 +348,7 @@ module internal CataGenerator =
RequiredGenerics = typeArgs
}
let rec dealWithType (typeArgs : SynType list option) (stripped : SynType) =
let rec dealWithType (typeArgs : int list option) (stripped : SynType) =
match stripped with
| ListType child ->
let gone = go (prefix + "_") None child
@@ -382,7 +389,20 @@ module internal CataGenerator =
| SynType.App (ty, _, childTypeArgs, _, _, _, _) ->
match typeArgs with
| Some _ -> failwithf "Nested applications of types not supported in %+A" ty
| None -> dealWithType (Some childTypeArgs) (SynType.stripOptionalParen ty)
| None ->
let childTypeArgs =
childTypeArgs
|> List.map (fun generic ->
let generic =
match generic with
| SynType.Var (SynTypar.SynTypar (name, _, _), _) -> name
| _ -> failwithf "Unrecognised generic arg: %+A" generic
availableGenerics
|> List.findIndex (fun knownGeneric -> knownGeneric.idText = generic.idText)
)
dealWithType (Some childTypeArgs) (SynType.stripOptionalParen ty)
| SynType.LongIdent (SynLongIdent.SynLongIdent (ty, _, _)) -> dealWithPrimitive typeArgs stripped ty
| SynType.Var (typar, _) ->
{
@@ -633,7 +653,26 @@ module internal CataGenerator =
[ SynType.Var (generics.[getNameKeyUnion ty], range0) ],
true
)
| FieldDescription.NonRecursive ty -> ty
| FieldDescription.NonRecursive ty ->
match field.RequiredGenerics with
| None -> ty
| Some generics ->
let generics =
generics
|> List.map (fun i ->
let (SynTyparDecl.SynTyparDecl (_, typar)) = analysis.Typars.[i]
SynType.Var (typar, range0)
)
SynType.App (
ty,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
SynType.Fun (
SynType.SignatureParameter (
@@ -806,21 +845,18 @@ module internal CataGenerator =
prod.Fields
|> List.indexed
|> List.collect (fun (i, node) ->
let availableGenerics =
match node.Type with
| SynType.App (_, _, vars, _, _, _, _) -> vars
| _ -> []
match getNameUnion node.Type with
| None ->
analyse allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic
analyse typars allRecordTypes allUnionTypes i [ node ]
|> List.map CataUnionField.Basic
| Some name ->
match Map.tryFind (List.last(name).idText) recordTypes with
| None ->
analyse allRecordTypes allUnionTypes i [ node ] |> List.map CataUnionField.Basic
analyse typars allRecordTypes allUnionTypes i [ node ]
|> List.map CataUnionField.Basic
| Some fields ->
List.zip fields (analyse allRecordTypes allUnionTypes i fields)
List.zip fields (analyse typars allRecordTypes allUnionTypes i fields)
|> List.map (fun (field, analysis) -> Option.get field.Name, analysis)
|> CataUnionField.Record
|> List.singleton