From d8d3f279484a9a3e946037b06df87e2cf350f6c8 Mon Sep 17 00:00:00 2001 From: Patrick Stevens Date: Sat, 6 May 2023 16:54:17 +0100 Subject: [PATCH] Add shortening function (#1) --- MyriadPlugin/RemoveOptionsGenerator.fs | 117 +++++++++++++++++++++++-- UsePlugin/Generated.fs | 8 ++ UsePlugin/Program.fs | 23 +++-- UsePlugin/RecordFile.fs | 2 + UsePlugin/myriad.toml | 0 5 files changed, 135 insertions(+), 15 deletions(-) create mode 100644 UsePlugin/myriad.toml diff --git a/MyriadPlugin/RemoveOptionsGenerator.fs b/MyriadPlugin/RemoveOptionsGenerator.fs index 371735d..6810a8c 100644 --- a/MyriadPlugin/RemoveOptionsGenerator.fs +++ b/MyriadPlugin/RemoveOptionsGenerator.fs @@ -2,6 +2,7 @@ namespace MyriadPlugin open System open FSharp.Compiler.Syntax +open FSharp.Compiler.SyntaxTrivia open FSharp.Compiler.Xml open Myriad.Core @@ -20,8 +21,10 @@ module internal Create = // TODO: consider Microsoft.FSharp.Option or whatever it is | _ -> false - let (|OptionIdent|_|) (ident : SynLongIdent) = - if isOptionIdent ident then Some () else None + let (|OptionType|_|) (fieldType : SynType) = + match fieldType with + | SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when isOptionIdent ident -> Some innerType + | _ -> None let private removeOption (s : SynField) : SynField = let (SynField.SynField (synAttributeLists, @@ -36,7 +39,7 @@ module internal Create = let newType = match fieldType with - | SynType.App (SynType.LongIdent OptionIdent, _, [ innerType ], _, _, _, _) -> innerType + | OptionType innerType -> innerType | _ -> fieldType SynField.SynField ( @@ -50,7 +53,8 @@ module internal Create = range ) - let createCreate (xmlDoc : PreXmlDoc option) (fields : SynField list) = + // TODO: this option seems a bit odd + let createType (xmlDoc : PreXmlDoc option) (fields : SynField list) = let fields : SynField list = fields |> List.map removeOption let name = Ident.Create "Short" @@ -61,6 +65,103 @@ module internal Create = SynModuleDecl.Types ([ typeDecl ], range0) + let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynField list) = + let xmlDoc = PreXmlDoc.Create " Remove the optional members of the input." + + let returnInfo = + SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent withOptionsType)) + + let inputArg = Ident.Create "input" + let functionName = Ident.Create "shorten" + + let inputVal = + SynValData.SynValData ( + None, + SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty), + Some inputArg + ) + + let body = + fields + |> List.map (fun (SynField (_, _, id, fieldType, _, _, _, _)) -> + let id = + match id with + | None -> failwith "Expected record field to have an identifying name" + | Some id -> id + + let accessor = + SynExpr.DotGet ( + SynExpr.CreateIdent inputArg, + range0, + SynLongIdent.CreateFromLongIdent [ id ], + range0 + ) + + let body = + match fieldType with + | OptionType _ -> + SynExpr.CreateApp ( + SynExpr.CreateAppInfix ( + SynExpr.LongIdent ( + false, + SynLongIdent.SynLongIdent ( + [ Ident.Create "op_PipeRight" ], + [], + [ Some (IdentTrivia.OriginalNotation "|>") ] + ), + None, + range0 + ), + accessor + ), + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.CreateString "Option.defaultValue"), + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateFromLongIdent ( + withoutOptionsType @ [ Ident.Create (sprintf "Default%s" id.idText) ] + ) + ), + SynExpr.CreateUnit + ) + ) + ) + ) + | _ -> accessor + + (SynLongIdent.CreateFromLongIdent [ id ], true), Some body + ) + |> SynExpr.CreateRecord + + let pattern = + SynPat.LongIdent ( + SynLongIdent.CreateFromLongIdent [ functionName ], + None, + None, + SynArgPats.Pats + [ + SynPat.CreateTyped ( + SynPat.CreateNamed inputArg, + SynType.LongIdent (SynLongIdent.CreateFromLongIdent withoutOptionsType) + ) + |> SynPat.CreateParen + ], + None, + range0 + ) + + let binding = + SynBinding.Let ( + xmldoc = xmlDoc, + returnInfo = returnInfo, + expr = body, + valData = inputVal, + pattern = pattern + ) + + SynModuleDecl.CreateLet [ binding ] + let createRecordModule (namespaceId : LongIdent) (typeDefn : SynTypeDefn) = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = typeDefn @@ -71,9 +172,11 @@ module internal Create = match synTypeDefnRepr with | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> - let create = createCreate (Some doc) recordFields - - let decls = [ yield create ] + let decls = + [ + createType (Some doc) recordFields + createMaker [ Ident.Create "Short" ] recordId recordFields + ] let compilationRepresentation : SynAttribute = { diff --git a/UsePlugin/Generated.fs b/UsePlugin/Generated.fs index 1c8c3e2..c238a07 100644 --- a/UsePlugin/Generated.fs +++ b/UsePlugin/Generated.fs @@ -18,3 +18,11 @@ module RecordType = /// Yet another thing! C : float list } + + /// Remove the optional members of the input. + let shorten (input : RecordType) : Short = + { + A = input.A |> Option.defaultValue (RecordType.DefaultA ()) + B = input.B + C = input.C + } diff --git a/UsePlugin/Program.fs b/UsePlugin/Program.fs index 91e606f..162d178 100644 --- a/UsePlugin/Program.fs +++ b/UsePlugin/Program.fs @@ -3,17 +3,24 @@ module Program = let f : RecordType = { - A = Some 3 + A = Some 300 B = "hello" C = [ 0.3 ] } - let g : RecordType.Short = - { - A = 3 - B = "hello" - C = [ 0.3 ] - } + let g = RecordType.shorten f [] - let main _ = 0 + let main _ = + if not (f.B = g.B && f.C = g.C) then + failwith "Non-optional fields differed" + + match f.A with + | None -> + if g.A <> RecordType.DefaultA () then + failwith "Couldn't acquire default" + | Some a -> + if a <> g.A then + failwith "Didn't match existing f.A" + + 0 diff --git a/UsePlugin/RecordFile.fs b/UsePlugin/RecordFile.fs index b261175..da4343a 100644 --- a/UsePlugin/RecordFile.fs +++ b/UsePlugin/RecordFile.fs @@ -11,3 +11,5 @@ type RecordType = /// Yet another thing! C : float list } + + static member DefaultA () : int = 3 diff --git a/UsePlugin/myriad.toml b/UsePlugin/myriad.toml new file mode 100644 index 0000000..e69de29