diff --git a/Nu.sln b/Nu.sln index d87e5c3ad5..29b1d33df6 100644 --- a/Nu.sln +++ b/Nu.sln @@ -18,8 +18,6 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Nu.Template", "Nu\Nu.Templa {85D631A5-821A-4755-A68E-C1FFC64E469A} = {85D631A5-821A-4755-A68E-C1FFC64E469A} EndProjectSection EndProject -Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Prime", "Prime\Prime\Prime.fsproj", "{FE09AE81-B66B-42E0-8192-EADECEFC9893}" -EndProject Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "Nu.AStar", "Nu\Nu.AStar\Nu.AStar.csproj", "{61667008-EE77-43B4-8825-0231D241CCA6}" EndProject Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "Nu.SDL2", "Nu\Nu.SDL2\Nu.SDL2.csproj", "{F184A111-8C28-40B4-8CDE-7BF2A64B3CA7}" @@ -50,10 +48,6 @@ Global {F1768F36-9ED3-4C36-9DCE-9535AEFB0732}.Release|Any CPU.Build.0 = Release|Any CPU {4DBBAA23-56BA-43CB-AB63-C45D5FC1016F}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {4DBBAA23-56BA-43CB-AB63-C45D5FC1016F}.Release|Any CPU.ActiveCfg = Release|Any CPU - {FE09AE81-B66B-42E0-8192-EADECEFC9893}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {FE09AE81-B66B-42E0-8192-EADECEFC9893}.Debug|Any CPU.Build.0 = Debug|Any CPU - {FE09AE81-B66B-42E0-8192-EADECEFC9893}.Release|Any CPU.ActiveCfg = Release|Any CPU - {FE09AE81-B66B-42E0-8192-EADECEFC9893}.Release|Any CPU.Build.0 = Release|Any CPU {61667008-EE77-43B4-8825-0231D241CCA6}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {61667008-EE77-43B4-8825-0231D241CCA6}.Debug|Any CPU.Build.0 = Debug|Any CPU {61667008-EE77-43B4-8825-0231D241CCA6}.Release|Any CPU.ActiveCfg = Release|Any CPU diff --git a/Nu/Nu.Gaia/Nu.Gaia.fsproj b/Nu/Nu.Gaia/Nu.Gaia.fsproj index e2bdd2ae18..1214dcf435 100644 --- a/Nu/Nu.Gaia/Nu.Gaia.fsproj +++ b/Nu/Nu.Gaia/Nu.Gaia.fsproj @@ -1,5 +1,7 @@ + + Debug @@ -14,6 +16,8 @@ Nu.Gaia 4.4.3.0 + + true @@ -83,10 +87,16 @@ - ..\..\Prime\Prime.Dependencies\FParsec\FParsec.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsec.dll - ..\..\Prime\Prime.Dependencies\FParsec\FParsecCS.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsecCS.dll + + + ..\..\packages\FsCheck.2.10.10\lib\net452\FsCheck.dll + + + ..\..\packages\FsCheck.Xunit.2.10.10\lib\net452\FsCheck.Xunit.dll True @@ -101,6 +111,9 @@ ..\Nu.Dependencies\Nito.Collections.Deque\Nito.Collections.Deque.dll + + ..\..\packages\Prime.2.7.0\lib\net46\Prime.exe + ..\Nu.Dependencies\ScintillaNET\ScintillaNET.dll @@ -112,17 +125,12 @@ - ..\..\Prime\Prime.Dependencies\System.ValueTuple.4.3.0\lib\portable-net40+sl4+win8+wp8\System.ValueTuple.dll + ..\..\packages\System.ValueTuple.4.4.0\lib\netstandard1.0\System.ValueTuple.dll ..\Nu.Dependencies\TiledSharp\Release\TiledSharp.dll - - Prime - {fe09ae81-b66b-42e0-8192-eadecefc9893} - True - Nu.SDL2 {f184a111-8c28-40b4-8cde-7bf2a64b3ca7} @@ -139,16 +147,16 @@ True - ..\..\Prime\Prime.Dependencies\xunit\xunit.abstractions.dll + ..\..\packages\xunit.abstractions.2.0.1\lib\net35\xunit.abstractions.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.assert.dll + ..\..\packages\xunit.assert.2.3.1\lib\netstandard1.1\xunit.assert.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.core.dll + ..\..\packages\xunit.extensibility.core.2.3.1\lib\netstandard1.1\xunit.core.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.execution.desktop.dll + ..\..\packages\xunit.extensibility.execution.2.3.1\lib\net452\xunit.execution.desktop.dll @@ -158,4 +166,13 @@ + + + This project references NuGet package(s) that are missing on this computer. Use NuGet Package Restore to download them. For more information, see http://go.microsoft.com/fwlink/?LinkID=322105. The missing file is {0}. + + + + + + \ No newline at end of file diff --git a/Nu/Nu.Gaia/Packages.config b/Nu/Nu.Gaia/Packages.config index 77b54a2758..febaef4574 100644 --- a/Nu/Nu.Gaia/Packages.config +++ b/Nu/Nu.Gaia/Packages.config @@ -1,4 +1,17 @@  + + + + + + + + + + + + + \ No newline at end of file diff --git a/Nu/Nu.Pipe/Nu.Pipe.fsproj b/Nu/Nu.Pipe/Nu.Pipe.fsproj index 941fbed4ff..d587afe982 100644 --- a/Nu/Nu.Pipe/Nu.Pipe.fsproj +++ b/Nu/Nu.Pipe/Nu.Pipe.fsproj @@ -1,5 +1,7 @@ + + Debug @@ -14,6 +16,8 @@ 4.4.3.0 Nu.Pipe + + true @@ -71,10 +75,16 @@ - ..\..\Prime\Prime.Dependencies\FParsec\FParsec.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsec.dll - ..\..\Prime\Prime.Dependencies\FParsec\FParsecCS.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsecCS.dll + + + ..\..\packages\FsCheck.2.10.10\lib\net452\FsCheck.dll + + + ..\..\packages\FsCheck.Xunit.2.10.10\lib\net452\FsCheck.Xunit.dll ..\Nu.Dependencies\FSharpx.Collections\FSharpx.Collections.dll @@ -86,26 +96,45 @@ True + + ..\..\packages\Prime.2.7.0\lib\net46\Prime.exe + ..\Nu.Dependencies\SDL2#\Release\SDL2#.dll - - Prime - {fe09ae81-b66b-42e0-8192-eadecefc9893} - True - Nu {a7a6f758-e122-4c2c-9525-1f29802d007c} True - ..\..\Prime\Prime.Dependencies\System.ValueTuple.4.3.0\lib\portable-net40+sl4+win8+wp8\System.ValueTuple.dll + ..\..\packages\System.ValueTuple.4.4.0\lib\netstandard1.0\System.ValueTuple.dll + + + ..\..\packages\xunit.abstractions.2.0.1\lib\net35\xunit.abstractions.dll + + + ..\..\packages\xunit.assert.2.3.1\lib\netstandard1.1\xunit.assert.dll + + + ..\..\packages\xunit.extensibility.core.2.3.1\lib\netstandard1.1\xunit.core.dll + + + ..\..\packages\xunit.extensibility.execution.2.3.1\lib\net452\xunit.execution.desktop.dll + + + This project references NuGet package(s) that are missing on this computer. Use NuGet Package Restore to download them. For more information, see http://go.microsoft.com/fwlink/?LinkID=322105. The missing file is {0}. + + + + + + - \ No newline at end of file diff --git a/Prime/Prime/Prime.xunit b/Prime/Prime/Prime.xunit deleted file mode 100644 index 97b5503e00..0000000000 --- a/Prime/Prime/Prime.xunit +++ /dev/null @@ -1,7 +0,0 @@ - - - - - - - \ No newline at end of file diff --git a/Prime/Prime/Program.fs b/Prime/Prime/Program.fs deleted file mode 100644 index 39b6c9c394..0000000000 --- a/Prime/Prime/Program.fs +++ /dev/null @@ -1,99 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic -open System.Diagnostics -open Prime -module Program = - - /// The number of samples taken for each timing. - let [] Samples = 3 - - /// Performs some ad-hoc tests to compare performance of fns. - let runTimings fn name = - printfn "%s timings..." name - for _ in 1 .. Samples do - GC.Collect () - let watch = Stopwatch.StartNew () - fn () |> ignore - watch.Stop () - printfn "Run time: %A" watch.Elapsed - - /// Performs some ad-hoc tests to compare performance of maps. - let runMapTimings make lookup name = - printfn "%s timings..." name - let rand = Random 1 - let entries = [|for _ in 0 .. 524280 do yield let n = rand.Next () in (string n, (string n, string n))|] - for _ in 1 .. Samples do - GC.Collect () - let watch = Stopwatch.StartNew () - let made = make entries - watch.Stop () - GC.Collect () - let watch2 = Stopwatch.StartNew () - lookup entries made - watch2.Stop () - printfn "Make time: %A\tLookup time: %A\tRun time: %A" watch.Elapsed watch2.Elapsed (watch.Elapsed + watch2.Elapsed) - - /// Run timings. - /// NOTE: even if this timing functionality is cleared out, the main entry point must remain in tact due to - - /// https://github.com/Microsoft/visualfsharp/issues/1371#issuecomment-235101700 - let [] main _ = - - // run array timings - let array = [|0 .. 10000000|] - runTimings (fun () -> array |> Array.rev |> Array.sort |> Array.map (fun x -> x * 13) |> Array.filter (fun x -> x % 2 = 0)) "Array Compute" - - // run ulist timings - let ulist = UList.makeFromSeq Functional [|0 .. 10000000|] - runTimings (fun () -> ulist |> UList.rev |> UList.sort |> UList.map (fun x -> x * 13) |> UList.filter (fun x -> x % 2 = 0)) "UList Compute" - - // run ulist imperative timings - let ulist = UList.makeFromSeq Imperative [|0 .. 10000000|] - runTimings (fun () -> ulist |> UList.rev |> UList.sort |> UList.map (fun x -> x * 13) |> UList.filter (fun x -> x % 2 = 0)) "UList Imperative Compute" - - // run list timings - let list = [0 .. 10000000] - runTimings (fun () -> list |> List.rev |> List.sort |> List.map (fun x -> x * 13) |> List.filter (fun x -> x % 2 = 0)) "F# List Compute" - - // run map timings - runMapTimings - (fun entries -> Array.fold (fun map (k, v) -> Map.add k v map) Map.empty entries) - (fun entries map -> Array.iter (fun (k, _) -> Map.find k map |> ignore) entries) - "F# Map" - - // run hmap timings - runMapTimings - (fun entries -> Array.fold (fun map (k, v) -> HMap.add k v map) (HMap.makeEmpty ()) entries) - (fun entries map -> Array.iter (fun (k, _) -> HMap.find k map |> ignore) entries) - "HMap" - - // run tmap timings with computation expressions - runMapTimings - (fun entries -> Array.fold (fun map (k, v) -> TMap.add k v map) (TMap.makeEmpty Functional) entries) - (fun entries map -> entries |> Array.iter (fun (k, _) -> TMap.find k map |> ignore)) - "TMap" - - // run umap timings without computation expressions - runMapTimings - (fun entries -> Array.fold (fun map (k, v) -> UMap.add k v map) (UMap.makeEmpty Functional) entries) - (fun entries map -> Array.iter (fun (k, _) -> UMap.find k map |> ignore) entries) - "UMap" - - // run umap imperative timings without computation expressions - runMapTimings - (fun entries -> Array.fold (fun map (k, v) -> UMap.add k v map) (UMap.makeEmpty Imperative) entries) - (fun entries map -> Array.iter (fun (k, _) -> UMap.find k map |> ignore) entries) - "UMap Imperative" - - // run dictionary timings - let dic = Dictionary () - runMapTimings - (fun entries -> Array.iter (fun (k, v) -> if not (dic.ContainsKey k) then dic.Add (k, v)) entries) - (fun entries () -> Array.iter (fun (k, _) -> dic.[k] |> ignore) entries) - ".NET Dictionary" - - // success - 0 diff --git a/Prime/Prime/Rand.fs b/Prime/Prime/Rand.fs deleted file mode 100644 index 4bb9bc2e15..0000000000 --- a/Prime/Prime/Rand.fs +++ /dev/null @@ -1,106 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System - -[] -module RandModule = - - /// An immutable random number generator using the xorshift* algorithm. - type [] Rand = - private - { RandState : uint64 } - - [] - module Rand = - - /// Get the sample value used to generate the current random value. - let private sample rand = - let result = rand.RandState * 2685821657736338717UL - if result = UInt64.MaxValue then 0UL else result - - /// The default seed state for rand. - /// NOTE: number generated via http://www.random.org/bytes/ - let DefaultSeedState = 0xa529cb6f5f0385edUL - - /// Advance the state of rand, thus yielding a new outcome. - let advance rand = - let c = rand.RandState - let c = c ^^^ (c >>> 12) - let c = c ^^^ (c <<< 25) - let c = c ^^^ (c >>> 27) - { RandState = c } - - /// The internal state of rand, useful for serialization and duplication. - let getState rand = - rand.RandState - - /// Get the next random value as a double type. - let nextDouble rand = - let rand = advance rand - let sampleDouble = double (sample rand) - let sampleDoubleMax = double UInt64.MaxValue - let number = sampleDouble / sampleDoubleMax - (number, rand) - - /// Get the next random value below the given maximum as a double type. - let nextDoubleUnder max rand = - let (number, rand) = nextDouble rand - (number % max, rand) - - /// Get the next random value as a double type. - let nextSingle rand = - let (numberDouble, rand) = nextDouble rand - (single numberDouble, rand) - - /// Get the next random value below the given maximum as a single type. - let nextSingleUnder max rand = - let (number, rand) = nextSingle rand - (number % max, rand) - - /// Get the next random value as an int type. - /// NOTE: System.Random.Next will never return Int32.MaxValue, but this will. - let nextInt rand = - let rand = advance rand - let sampleInt = int (sample rand >>> 32) - let number = if sampleInt < 0 then sampleInt + Int32.MaxValue else sampleInt - (number, rand) - - /// Get the next random value below the given maximum as an int type. - let nextIntUnder max rand = - let (number, rand) = nextInt rand - (number % max, rand) - - /// Get the next random value as an int64 type. - /// NOTE: System.Random.Next will never return Int64.MaxValue, but this will. - let nextInt64 rand = - let rand = advance rand - let number = sample rand - (number, rand) - - /// Get the next random value below the given maximum as an int64 type. - let nextInt64Under max rand = - let (number, rand) = nextInt64 rand - (number % max, rand) - - /// Make a rand value generator from the given seed state. - /// May not be zero. - let makeFromSeedState seedState = - if seedState = 0UL then failwith "Seed for Rand may not be zero." - { RandState = seedState } - - /// Make a rand value generator from the given int seed state. - /// May not be zero. - let makeFromInt (intSeedState : int) = - let lowState = uint64 intSeedState - let highState = uint64 intSeedState <<< 32 - let seedState = highState ||| lowState - makeFromSeedState seedState - - /// Make a rand value generator from the default seed state. - let make () = - makeFromSeedState DefaultSeedState - -/// An immutable random number generator using the xorshift* algorithm. -type Rand = RandModule.Rand \ No newline at end of file diff --git a/Prime/Prime/RandTests.fs b/Prime/Prime/RandTests.fs deleted file mode 100644 index 36a704a6e1..0000000000 --- a/Prime/Prime/RandTests.fs +++ /dev/null @@ -1,33 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime.Tests -open System -open Xunit -open Prime -module RandTests = - - let [] Samples = 32768 - - let makeSamples (next : Rand -> ('n * Rand)) = - let randRef = ref (Rand.make ()) - [for _ in 0 .. Samples - 1 do - let (n, r) = next !randRef - randRef := r - yield n] - - let [] nextDoubleIsInRange () = - let samples = makeSamples Rand.nextDouble - let avg = List.average samples - Assert.InRange (avg, 0.49, 0.51) - - let [] nextSingleIsInRange () = - let samples = makeSamples Rand.nextSingle - let avg = List.average samples - Assert.InRange (avg, 0.49f, 0.51f) - - let [] nextIntIsInRange () = - let samples = makeSamples Rand.nextInt - let sampleDoubles = List.map double samples - let avg = List.average sampleDoubles - Assert.InRange (avg, 1003741823.0, 1143741823.0) \ No newline at end of file diff --git a/Prime/Prime/Reflection.fs b/Prime/Prime/Reflection.fs deleted file mode 100644 index 4e7213216b..0000000000 --- a/Prime/Prime/Reflection.fs +++ /dev/null @@ -1,324 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.ComponentModel -open System.Collections -open System.Collections.Generic -open System.Text -open System.Reflection -open Microsoft.FSharp.Reflection - -/// An attribute to specify the default value of a property. -type [] DefaultValueAttribute (defaultValue : obj) = - inherit Attribute () - member this.DefaultValue = defaultValue - -/// An evaluatable expression for defining a property. -type [] PropertyExpr = - | DefineExpr of DefineExpr : obj - | VariableExpr of VariableExpr : (unit -> obj) - - /// Evaluate a property expression. - static member eval expr = - match expr with - | DefineExpr value -> value - | VariableExpr fn -> fn () - -/// The definition of a data-driven property. -type [] PropertyDefinition = - { PropertyName : string - PropertyType : Type - PropertyExpr : PropertyExpr } - - /// Validate a property definition. - static member validate propertyDefinition = - if propertyDefinition.PropertyName = "FacetNames" then failwith "FacetNames cannot be an intrinsic property." - if propertyDefinition.PropertyName = "OverlayNameOpt" then failwith "OverlayNameOpt cannot be an intrinsic property." - if Array.exists (fun gta -> gta = typeof) propertyDefinition.PropertyType.GenericTypeArguments then - failwith - ("Generic property definition lacking type information for property '" + propertyDefinition.PropertyName + "'. " + - "Use explicit typing on all values that carry incomplete type information such as empty lists, empty sets, and none options.") - - /// Make a property definition. - static member make propertyName propertyType propertyExpr = - { PropertyName = propertyName; PropertyType = propertyType; PropertyExpr = propertyExpr } - - /// Make a property definition, validating it in the process. - static member makeValidated propertyName propertyType propertyExpr = - let result = PropertyDefinition.make propertyName propertyType propertyExpr - PropertyDefinition.validate result - result - -/// In tandem with the define literal, grants a nice syntax to define value properties. -type [] ValueDescription = - { ValueDescription : unit } - - /// Some magic syntax for composing value properties. - static member (?) (_, propertyName) = - fun (value : 'v) -> - PropertyDefinition.makeValidated propertyName typeof<'v> (DefineExpr value) - -/// In tandem with the variable literal, grants a nice syntax to define variable properties. -type [] VariableDescription = - { VariableDescription : unit } - - /// Some magic syntax for composing variable properties. - static member (?) (_, propertyName) = - fun (variable : unit -> 'v) -> - PropertyDefinition.makeValidated propertyName typeof<'v> (VariableExpr (fun () -> variable () :> obj)) - -/// In tandem with the property literal, grants a nice syntax to denote properties. -type [] PropertyDescription = - { PropertyDescription : unit } - - /// Some magic syntax for composing value properties. - static member inline (?) (_, propertyName : string) = - propertyName - -/// Describes a property. -type [] PropertyDescriptor = - { PropertyName : string - PropertyType : Type } - -/// A vanilla property. -type [] Property = - { mutable PropertyType : Type - mutable PropertyValue : obj } - -/// A designer-defined property. -type [] DesignerProperty = - { mutable DesignerType : Type - mutable DesignerValue : obj } - -/// A map of propertyies. -/// NOTE: Xtension uses UMap because it's slightly faster when used in the Nu game engine, but -/// it's not necessarily the right decision in other contexts. However, I'm sticking with this -/// choice since the performance of Nu trumps other usages for now. -type PropertyMap = UMap - -[] -module ReflectionModule = - - /// In tandem with the ValueDefinition type, grants a nice syntax to define value properties. - let Define = { ValueDescription = () } - - /// In tandem with the VariableDefinition type, grants a nice syntax to define variable properties. - let Variable = { VariableDescription = () } - - /// In tandem with the PropertyDescriptor type, grants a nice syntax to denote properties. - let Property = { PropertyDescription = () } - -module Reflection = - - // NOTE: had to do some reflection hacking get this assembly as it was the only way I could - // access ListModule.OfSeq dynamically. - let private FSharpCoreAssembly = - Array.find - (fun (assembly : Assembly) -> assembly.FullName.StartsWith ("FSharp.Core,", StringComparison.Ordinal)) - (AppDomain.CurrentDomain.GetAssemblies ()) - - let objToObjList (source : obj) = - let iEnumerable = source :?> IEnumerable - List.ofSeq (enumerable iEnumerable) - - let objToKeyValuePair (source : obj) = - let kvpType = source.GetType () - let key = (kvpType.GetProperty "Key").GetValue (source, null) - let value = (kvpType.GetProperty "Value").GetValue (source, null) - KeyValuePair (key, value) - - let objToOption (source : obj) = - if isNotNull source then - let optType = source.GetType () - let value = (optType.GetProperty "Value").GetValue (source, null) - Some value - else None - - let objToComparableSet (source : obj) = - let iEnumerable = source :?> IEnumerable - Set.ofSeq (enumerable iEnumerable) - - let objsToKeyValuePair fst snd (pairType : Type) = - Activator.CreateInstance (pairType, [|fst; snd|]) - - let objsToCollection collectionTypeName (sequenceType : Type) (objs : _ seq) = - let gargs = if sequenceType.IsArray then [|sequenceType.GetElementType ()|] else (sequenceType.GetGenericArguments ()) - let cast = (typeof.GetMethod ("Cast", BindingFlags.Static ||| BindingFlags.Public)).MakeGenericMethod gargs - let ofSeq = ((FSharpCoreAssembly.GetType collectionTypeName).GetMethod ("OfSeq", BindingFlags.Static ||| BindingFlags.Public)).MakeGenericMethod gargs - ofSeq.Invoke (null, [|cast.Invoke (null, [|objs|])|]) - - let pairsToMapping collectionTypeName (mappingType : Type) (pairs : _ seq) = - let gargs = mappingType.GetGenericArguments () - match gargs with - | [|fstType; sndType|] -> - let pairType = typedefof>.MakeGenericType [|fstType; sndType|] - let cast = (typeof.GetMethod ("Cast", BindingFlags.Static ||| BindingFlags.Public)).MakeGenericMethod [|pairType|] - let ofSeq = ((FSharpCoreAssembly.GetType collectionTypeName).GetMethod ("OfSeq", BindingFlags.Static ||| BindingFlags.Public)).MakeGenericMethod [|fstType; sndType|] - ofSeq.Invoke (null, [|cast.Invoke (null, [|pairs|])|]) - | _ -> failwithumf () - - let objsToArray arrayType objs = - objsToCollection "Microsoft.FSharp.Collections.ArrayModule" arrayType objs - - let objsToList listType objs = - objsToCollection "Microsoft.FSharp.Collections.ListModule" listType objs - - let objsToSet setType objs = - objsToCollection "Microsoft.FSharp.Collections.SetModule" setType objs - - let pairsToMap mapType objs = - pairsToMapping "Microsoft.FSharp.Collections.MapModule" mapType objs - -module Type = - - /// Try to get an existing type with the given unqualified name. Time-intensive. - let TryGetTypeUnqualified name = - match Type.GetType name with - | null -> - let allAssemblies = AppDomain.CurrentDomain.GetAssemblies () - let types = - Array.choose - (fun (assembly : Assembly) -> - match assembly.GetType name with - | null -> None - | ty -> Some ty) - allAssemblies - Array.tryHead types - | ty -> Some ty - - /// Get an existing type with the given unqualified name. Time-intensive. - let GetTypeUnqualified name = - match TryGetTypeUnqualified name with - | Some ty -> ty - | None -> failwith ("Could not find type with unqualified name '" + name + "'.") - - /// Get the first property that is signalled to be preferred by the 'preference' predicate. - let GetPropertyByPreference (preference, properties) = - let preferredOpt = Array.tryFind preference properties - if Array.isEmpty properties then null - else - match preferredOpt with - | Some preferred -> preferred - | None -> Array.head properties - -[] -module TypeExtension = - - /// Type extension for Type. - type Type with - - /// Attempt to get the default value for a type. - /// Never returns null. - member this.TryGetDefaultValue () = - if this.IsPrimitive then Some (Activator.CreateInstance this) - elif this = typeof then Some (String.Empty :> obj) - elif this.Name = typedefof<_ array>.Name then Some (Reflection.objsToArray this [||]) - elif this.Name = typedefof<_ list>.Name then Some (Reflection.objsToList this []) - elif this.Name = typedefof<_ Set>.Name then Some (Reflection.objsToSet this Set.empty) - elif this.Name = typedefof>.Name then Some (Reflection.pairsToMap this Map.empty) - elif FSharpType.IsUnion this then - let unionCases = FSharpType.GetUnionCases this - if (unionCases.[0].GetFields ()).Length = 0 - then Some (FSharpValue.MakeUnion (unionCases.[0], [||])) - else None - elif isNotNull (this.GetConstructor [||]) then Some (Activator.CreateInstance ()) - else None - - /// Get the default value for a type. - /// Never returns null. - member this.GetDefaultValue () = - match this.TryGetDefaultValue () with - | Some value -> value - | None -> failwithumf () - - /// Get the type descriptor for this type as returned by the global TypeDescriptor. - member this.GetTypeDescriptor () = - (TypeDescriptor.GetProvider this).GetTypeDescriptor this - - /// Try to get a custom type converter for the given type. - member this.TryGetCustomTypeConverter () = - let globalConverterAttributes = - [| for attribute in TypeDescriptor.GetAttributes this do - match attribute with - | :? TypeConverterAttribute as tca -> yield tca - | _ -> () |] - let typeConverterAttributes = - this.GetCustomAttributes (typeof, true) |> - Array.map (fun attr -> attr :?> TypeConverterAttribute) |> - Array.append globalConverterAttributes - if not (Array.isEmpty typeConverterAttributes) then - let typeConverterAttribute = Array.head typeConverterAttributes - let typeConverterTypeName = typeConverterAttribute.ConverterTypeName - let typeConverterType = Type.GetType typeConverterTypeName - match typeConverterType.GetConstructor [|typeof|] with - | null -> (typeConverterType.GetConstructor [||]).Invoke [||] :?> TypeConverter |> Some - | constructor1 -> constructor1.Invoke [|this|] :?> TypeConverter |> Some - else None - - /// Get a property with the given name that can be written to, or null. - member this.GetPropertyWritable propertyName = - let propertyOpt = - Array.tryFind - (fun (property : PropertyInfo) -> property.Name = propertyName && property.CanWrite) - (this.GetProperties ()) - match propertyOpt with - | Some property -> property - | None -> null - - /// Get all the properties with the given name. - member this.GetProperties propertyName = - Array.filter - (fun (property : PropertyInfo) -> property.Name = propertyName) - (this.GetProperties ()) - - /// Get all the properties that can be written to. - member this.GetPropertiesWritable () = - Array.filter - (fun (property : PropertyInfo) -> property.CanWrite) - (this.GetProperties ()) - - /// Get all the properties with the give name that can be written to. - member this.GetPropertiesWritable propertyName = - Array.filter - (fun (property : PropertyInfo) -> property.Name = propertyName && property.CanWrite) - (this.GetProperties ()) - - /// Get the first property with the given name that is signalled to be preferred by the 'preference' predicate. - member this.GetPropertyByPreference (preference, propertyName) = - let properties = this.GetProperties propertyName - Type.GetPropertyByPreference (preference, properties) - - /// Get the property with the given name, preferring the variant that can be written to, or null if none found. - member this.GetPropertyPreferWritable propertyName = - this.GetPropertyByPreference ((fun (property : PropertyInfo) -> property.CanWrite), propertyName) - - /// Get all the properties that are signalled to be preferred by the 'preference' predicate. - member this.GetPropertiesByPreference preference = - let propertiesLayered = - Array.groupBy - (fun (property : PropertyInfo) -> property.Name) - (this.GetProperties ()) - let propertieOpts = - Array.map - (fun (_, properties) -> Type.GetPropertyByPreference (preference, properties)) - propertiesLayered - Array.filter isNotNull propertieOpts - - /// Get all the properties, preferring those that can be written to if there is a name clash. - member this.GetPropertiesPreferWritable () = - this.GetPropertiesByPreference (fun (property : PropertyInfo) -> property.CanWrite) - - /// Get the generic name of the type, EG - Option - member this.GetGenericName () : string = - let sb = StringBuilder () - let name = this.Name - if this.IsGenericType then - let gargs = this.GetGenericArguments () |> Array.map (fun garg -> garg.GetGenericName ()) - ignore (sb.Append (name.Substring (0, name.IndexOf '`'))) - ignore (sb.Append "<") - ignore (sb.Append (String.Join (", ", gargs))) - ignore (sb.Append ">") - sb.ToString () - else name \ No newline at end of file diff --git a/Prime/Prime/Relation.fs b/Prime/Prime/Relation.fs deleted file mode 100644 index 86c51c9e70..0000000000 --- a/Prime/Prime/Relation.fs +++ /dev/null @@ -1,151 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.ComponentModel -open System.Reflection -open Prime - -/// Converts Relation types. -type RelationConverter (targetType : Type) = - inherit TypeConverter () - - override this.CanConvertTo (_, destType) = - destType = typeof || - destType = typeof || - destType = targetType - - override this.ConvertTo (_, _, source, destType) = - if destType = typeof then - let toStringMethod = targetType.GetMethod "ToString" - toStringMethod.Invoke (source, null) - elif destType = typeof then - let toStringMethod = targetType.GetMethod "ToString" - let relationStr = toStringMethod.Invoke (source, null) :?> string - if Symbol.shouldBeExplicit relationStr then String (relationStr, None) :> obj - else Atom (relationStr, None) :> obj - elif destType = targetType then source - else failconv "Invalid RelationConverter conversion to source." None - - override this.CanConvertFrom (_, sourceType) = - sourceType = typeof || - sourceType = typeof || - sourceType = targetType - - override this.ConvertFrom (_, _, source) = - match source with - | :? string as fullName -> - let makeFromStringFunction = targetType.GetMethod ("makeFromString", BindingFlags.Static ||| BindingFlags.Public) - let makeFromStringFunctionGeneric = makeFromStringFunction.MakeGenericMethod ((targetType.GetGenericArguments ()).[0]) - makeFromStringFunctionGeneric.Invoke (null, [|fullName|]) - | :? Symbol as relationSymbol -> - match relationSymbol with - | Atom (fullName, _) | String (fullName, _) -> - let makeFromStringFunction = targetType.GetMethod ("makeFromString", BindingFlags.Static ||| BindingFlags.Public) - let makeFromStringFunctionGeneric = makeFromStringFunction.MakeGenericMethod ((targetType.GetGenericArguments ()).[0]) - makeFromStringFunctionGeneric.Invoke (null, [|fullName|]) - | Number (_, _) | Quote (_, _) | Symbols (_, _) -> - failconv "Expected Symbol or String for conversion to Relation." (Some relationSymbol) - | _ -> - if targetType.IsInstanceOfType source then source - else failconv "Invalid RelationConverter conversion from source." None - -[] -module RelationModule = - - /// A relation that can be resolved to an address via contextual resolution. - type [)>] 'a Relation = - private - { NameOpts : string option list - TypeCarrier : 'a -> unit } - - /// Make a relation from a list of names where "?" names are empty. - static member makeFromList<'a> (names : string list) : 'a Relation = - let nameOpts = List.map (fun name -> match name with Constants.Relation.SlotStr -> None | _ -> Some name) names - { NameOpts = nameOpts; TypeCarrier = fun (_ : 'a) -> () } - - /// Make a relation from an address where "?" names are empty. - static member makeFromAddress<'a> (address : 'a Address) : 'a Relation = - let names = Address.getNames address - Relation.makeFromList<'a> names - - /// Make a relation from a '/' delimited string where '?' names are empty. - /// NOTE: do not move this function as the RelationConverter's reflection code relies on it being exactly here! - static member makeFromString<'a> (relationStr : string) : 'a Relation = - let names = relationStr.Split Constants.Address.Separator |> List.ofSeq - Relation.makeFromList<'a> names - - /// Hash a Relation. - static member hash (relation : 'a Relation) = - List.hash relation.NameOpts - - /// Equate Relations. - static member equals relation relation2 = - relation.NameOpts = relation2.NameOpts - - /// Resolve a relationship to an address. - static member resolve<'a, 'b> (address : 'a Address) (relation : 'b Relation) = - // OPTIMIZATION: using array for speed. - let addressNames = Array.ofList (Address.getNames address) - let nameOpts = Array.ofList relation.NameOpts - for i in 0 .. Math.Min (addressNames.Length, nameOpts.Length) - 1 do - match nameOpts.[i] with - | None -> nameOpts.[i] <- Some addressNames.[i] - | Some _ -> () - match Array.definitizePlus nameOpts with - | (true, names) -> Address.makeFromList<'b> (List.ofArray names) - | (false, _) -> failwith ("Invalid relation resolution for address '" + string address + "' and relation '" + string relation + "'.") - - /// Unresolve an address to the most general form in the context of another address. - static member unresolve<'a, 'b> (address : 'a Address) (address2 : 'b Address) : 'b Relation = - let names = Address.getNames address - let names2 = Address.getNames address2 - let namesMatching = - let mutable namesMatching = 0 - let mutable enr = (names :> _ seq).GetEnumerator () - let mutable enr2 = (names2 :> _ seq).GetEnumerator () - while (enr.MoveNext() && enr2.MoveNext ()) do - if enr.Current = enr2.Current then - namesMatching <- inc namesMatching - namesMatching - let names2' = List.trySkip namesMatching names2 - { NameOpts = (List.append (List.init namesMatching (fun _ -> None)) (List.map Some names2')); TypeCarrier = fun (_ : 'b) -> () } - - interface 'a Relation IEquatable with - member this.Equals that = - Relation<'a>.equals this that - - override this.Equals that = - match that with - | :? ('a Relation) as that -> Relation<'a>.equals this that - | _ -> false - - override this.GetHashCode () = - Relation<'a>.hash this - - override this.ToString () = - let names = List.map (fun nameOpt -> match nameOpt with Some name -> name | None -> Constants.Relation.SlotStr) this.NameOpts - String.concat Constants.Address.SeparatorStr names - - [] - module Relation = - - /// Make a relation from a list of option names. - let makeFromList<'a> nameOptsList = - { NameOpts = nameOptsList; TypeCarrier = fun (_ : 'a) -> () } - - /// Make a relation from a '/' delimited string. - let makeFromString<'a> relationStr = - Relation<'a>.makeFromString relationStr - - /// Get the optional names of a relation. - let getNameOpts relation = - relation.NameOpts - - /// Change the type of an address. - let changeType<'a, 'b> (relation : 'a Relation) = - { NameOpts = relation.NameOpts; TypeCarrier = fun (_ : 'b) -> () } - -/// A relation that can be resolved to an address via projection. -type 'a Relation = 'a RelationModule.Relation \ No newline at end of file diff --git a/Prime/Prime/Scripting.fs b/Prime/Prime/Scripting.fs deleted file mode 100644 index 5c9105c2fb..0000000000 --- a/Prime/Prime/Scripting.fs +++ /dev/null @@ -1,874 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic -open System.ComponentModel -open Prime -module Scripting = - - type Pluggable = - inherit IComparable - abstract member TypeName : string - abstract member ToSymbol : unit -> Symbol - - and [] CachedBinding = - | UncachedBinding - | DeclarationBinding of Expr - | ProceduralBinding of int * int - - and [] BindingType = - | UnknownBindingType - | Intrinsic - | Extrinsic - | Environmental - - and [] Binding = - | VariableBinding of VarName : string * VarValue : Expr - | FunctionBinding of FunName : string * FunArgs : string array * FunLambda : Expr - - and [] Breakpoint = - { mutable BreakEnabled : bool - mutable BreakCondition : Expr } - - and [] Codata = - | Empty - | Add of Codata * Codata - | Unfold of Expr * Expr - | Conversion of Expr list - - and [); - CustomEquality; - CustomComparison>] - Expr = - - (* Primitive Value Types *) - | Violation of string list * string * SymbolOrigin option - | Unit - | Bool of bool - | Int of int - | Int64 of int64 - | Single of single - | Double of double - | String of string - | Keyword of string - | Pluggable of Pluggable - - (* Primitive Data Structures *) - | Tuple of Expr array - | Union of string * Expr array - | Option of Expr option - | Codata of Codata - | List of Expr list - | Ring of Set - | Table of Map - - (* Intermediate Data Structures *) - | Record of string * Map * Expr array - | UnionUnevaled of string * Expr array - | TableUnevaled of (Expr * Expr) list - | RecordUnevaled of string * (string * Expr) list - - (* Special Forms *) - | Binding of string * CachedBinding ref * BindingType ref * SymbolOrigin option - | TryUpdate of Expr * Expr * Expr * Breakpoint * SymbolOrigin option - | Update of Expr * Expr * Expr * Breakpoint * SymbolOrigin option - | Apply of Expr array * Breakpoint * SymbolOrigin option - | ApplyAnd of Expr array * Breakpoint * SymbolOrigin option - | ApplyOr of Expr array * Breakpoint * SymbolOrigin option - | Let of Binding * Expr * SymbolOrigin option - | LetMany of Binding list * Expr * SymbolOrigin option - | Fun of string array * int * Expr * bool * obj option * SymbolOrigin option - | If of Expr * Expr * Expr * SymbolOrigin option - | Match of Expr * (Expr * Expr) array * SymbolOrigin option - | Select of (Expr * Expr) array * SymbolOrigin option - | Try of Expr * (string list * Expr) list * SymbolOrigin option - | Do of Expr list * SymbolOrigin option - | Quote of Expr * SymbolOrigin option - - (* Declarations - only work at the top level. *) - | Define of Binding * SymbolOrigin option - - static member tryGetOrigin expr = - match expr with - | Violation (_, _, originOpt) -> originOpt - | Unit - | Bool _ - | Int _ - | Int64 _ - | Single _ - | Double _ - | String _ - | Keyword _ - | Tuple _ - | Union _ - | Pluggable _ - | Option _ - | Codata _ - | List _ - | Ring _ - | Table _ - | Record _ - | UnionUnevaled _ - | TableUnevaled _ - | RecordUnevaled _ -> None - | Binding (_, _, _, originOpt) - | TryUpdate (_, _, _, _, originOpt) - | Update (_, _, _, _, originOpt) - | Apply (_, _, originOpt) - | ApplyAnd (_, _, originOpt) - | ApplyOr (_, _, originOpt) - | Let (_, _, originOpt) - | LetMany (_, _, originOpt) - | Fun (_, _, _, _, _, originOpt) - | If (_, _, _, originOpt) - | Match (_, _, originOpt) - | Select (_, originOpt) - | Try (_, _, originOpt) - | Do (_, originOpt) - | Quote (_, originOpt) - | Define (_, originOpt) -> originOpt - - static member equals left right = - match (left, right) with - | (Violation (leftNames, leftError, _), Violation (rightNames, rightError, _)) -> (leftNames, leftError) = (rightNames, rightError) - | (Unit, Unit) -> true - | (Bool left, Bool right) -> left = right - | (Int left, Int right) -> left = right - | (Int64 left, Int64 right) -> left = right - | (Single left, Single right) -> left = right - | (Double left, Double right) -> left = right - | (String left, String right) -> left = right - | (Keyword left, Keyword right) -> left = right - | (Pluggable left, Pluggable right) -> left = right - | (Tuple left, Tuple right) -> left = right - | (Union (leftName, leftExprs), Union (rightName, rightExprs)) -> (leftName, leftExprs) = (rightName, rightExprs) - | (Option left, Option right) -> left = right - | (Codata left, Codata right) -> left = right - | (List left, List right) -> left = right - | (Ring left, Ring right) -> left = right - | (Table left, Table right) -> left = right - | (Record (leftName, leftMap, leftExprs), Record (rightName, rightMap, rightExprs)) -> (leftName, leftMap, leftExprs) = (rightName, rightMap, rightExprs) - | (UnionUnevaled (leftName, leftExprs), UnionUnevaled (rightName, rightExprs)) -> (leftName, leftExprs) = (rightName, rightExprs) - | (TableUnevaled left, TableUnevaled right) -> left = right - | (RecordUnevaled (leftName, leftExprs), RecordUnevaled (rightName, rightExprs)) -> (leftName, leftExprs) = (rightName, rightExprs) - | (Binding (left, _, _, _), Binding (right, _, _, _)) -> left = right - | (TryUpdate (leftExpr, leftExpr2, leftExpr3, _, _), TryUpdate (rightExpr, rightExpr2, rightExpr3, _, _)) -> (leftExpr, leftExpr2, leftExpr3) = (rightExpr, rightExpr2, rightExpr3) - | (Update (leftExpr, leftExpr2, leftExpr3, _, _), TryUpdate (rightExpr, rightExpr2, rightExpr3, _, _)) -> (leftExpr, leftExpr2, leftExpr3) = (rightExpr, rightExpr2, rightExpr3) - | (Apply (left, _, _), Apply (right, _, _)) -> left = right - | (ApplyAnd (left, _, _), ApplyAnd (right, _, _)) -> left = right - | (ApplyOr (left, _, _), ApplyOr (right, _, _)) -> left = right - | (Let (leftBinding, leftBody, _), Let (rightBinding, rightBody, _)) -> (leftBinding, leftBody) = (rightBinding, rightBody) - | (LetMany (leftBindings, leftBody, _), LetMany (rightBindings, rightBody, _)) -> (leftBindings, leftBody) = (rightBindings, rightBody) - | (Fun (leftPars, _, leftBody, _, _, _), Fun (rightPars, _, rightBody, _, _, _)) -> (leftPars, leftBody) = (rightPars, rightBody) - | (If (leftConditional, leftConsequent, leftAlternative, _), If (rightConditional, rightConsequent, rightAlternative, _)) -> (leftConditional, leftConsequent, leftAlternative) = (rightConditional, rightConsequent, rightAlternative) - | (Match (leftInput, leftCases, _), Match (rightInput, rightCases, _)) -> (leftInput, leftCases) = (rightInput, rightCases) - | (Select (left, _), Select (right, _)) -> left = right - | (Try (leftInput, leftCases, _), Try (rightInput, rightCases, _)) -> (leftInput, leftCases) = (rightInput, rightCases) - | (Do (left, _), Do (right, _)) -> left = right - | (Quote (left, _), Quote (right, _)) -> left = right - | (Define (left, _), Define (right, _)) -> left = right - | (_, _) -> false - - static member compare left right = - match (left, right) with - | (Violation (leftNames, leftError, _), Violation (rightNames, rightError, _)) -> compare (leftNames, leftError) (rightNames, rightError) - | (Unit, Unit) -> 0 - | (Bool left, Bool right) -> compare left right - | (Int left, Int right) -> compare left right - | (Int64 left, Int64 right) -> compare left right - | (Single left, Single right) -> compare left right - | (Double left, Double right) -> compare left right - | (String left, String right) -> compare left right - | (Keyword left, Keyword right) -> compare left right - | (Pluggable left, Pluggable right) -> compare left right - | (Tuple left, Tuple right) -> compare left right - | (Union (leftName, leftExprs), Union (rightName, rightExprs)) -> compare (leftName, leftExprs) (rightName, rightExprs) - | (Option left, Option right) -> compare left right - | (Codata left, Codata right) -> compare left right - | (List left, List right) -> compare left right - | (Ring left, Ring right) -> compare left right - | (Table left, Table right) -> compare left right - | (Record (leftName, leftMap, leftExprs), Record (rightName, rightMap, rightExprs)) -> compare (leftName, leftMap, leftExprs) (rightName, rightMap, rightExprs) - | (UnionUnevaled (leftName, leftExprs), UnionUnevaled (rightName, rightExprs)) -> compare (leftName, leftExprs) (rightName, rightExprs) - | (TableUnevaled left, TableUnevaled right) -> compare left right - | (RecordUnevaled (leftName, leftExprs), RecordUnevaled (rightName, rightExprs)) -> compare (leftName, leftExprs) (rightName, rightExprs) - | (_, _) -> -1 - - override this.GetHashCode () = - match this with - | Violation (names, error, _) -> hash names ^^^ hash error - | Unit -> 0 - | Bool value -> hash value - | Int value -> hash value - | Int64 value -> hash value - | Single value -> hash value - | Double value -> hash value - | String value -> hash value - | Keyword value -> hash value - | Pluggable value -> hash value - | Tuple value -> hash value - | Union (name, fields) -> hash (name, fields) - | Option value -> hash value - | Codata value -> hash value - | List value -> hash value - | Ring value -> hash value - | Table value -> hash value - | Record (name, map, fields) -> hash (name, map, fields) - | UnionUnevaled (name, fields) -> hash (name, fields) - | TableUnevaled value -> hash value - | RecordUnevaled (name, fields) -> hash (name, fields) - | _ -> -1 - - override this.Equals that = - match that with - | :? Expr as that -> Expr.equals this that - | _ -> failwithumf () - - interface Expr IComparable with - member this.CompareTo that = - Expr.compare this that - - interface IComparable with - member this.CompareTo that = - match that with - | :? Expr as that -> (this :> Expr IComparable).CompareTo that - | _ -> failwithumf () - - /// Converts Expr types. - and ExprConverter () = - inherit TypeConverter () - - member this.SymbolToExpr (symbol : Symbol) = - this.ConvertFrom symbol :?> Expr - - member this.SymbolsToExpr (symbols : Symbol list) = - List.map this.SymbolToExpr symbols - - member this.BindingToSymbols (binding : Binding) = - match binding with - | VariableBinding (name, value) -> - let nameSymbol = Atom (name, None) - let valueSymbol = this.ExprToSymbol value - [nameSymbol; valueSymbol] - | FunctionBinding (name, pars, body) -> - let nameSymbol = Atom (name, None) - let parSymbols = Array.map (fun par -> Atom (par, None)) pars - let parsSymbol = Symbols (List.ofArray parSymbols, None) - let bodySymbol = this.ExprToSymbol body - [nameSymbol; parsSymbol; bodySymbol] - - member this.BindingToSymbol binding = - Symbols (this.BindingToSymbols binding, None) - - member this.CodataToSymbol codata = - match codata with - | Empty -> Atom ("empty", None) - | Add (left, right) -> Symbols ([Atom ("+", None); this.CodataToSymbol left; this.CodataToSymbol right], None) - | Unfold (unfolder, state) -> Symbols ([Atom ("codata", None); this.ExprToSymbol unfolder; this.ExprToSymbol state], None) - | Conversion source -> Symbols ([Atom ("toCodata", None); this.ExprsToSymbol source], None) - - member this.ExprToSymbol (expr : Expr) = - this.ConvertTo (expr, typeof) :?> Symbol - - member this.ExprsToSymbol exprs = - Symbols (List.map this.ExprToSymbol exprs, None) - - member this.ExprsToIndex expr expr2 = - let indexSymbol = Atom ("Index", None) - Symbols ([indexSymbol; this.ExprToSymbol expr; this.ExprToSymbol expr2], None) - - member this.IndexToExprs indices = - match indices with - | Symbols ([Atom ("Index", _); target; indexer], _) -> Some (target, indexer) - | _ -> None - - member this.SymbolsToBindingOpt bindingSymbols = - match bindingSymbols with - | [Atom (bindingName, _); bindingBody] -> - let binding = VariableBinding (bindingName, this.SymbolToExpr bindingBody) - Some binding - | [Atom (bindingName, _); Symbols (bindingArgs, _); bindingBody] -> - let (bindingArgs, bindingErrors) = List.split (function Atom _ -> true | _ -> false) bindingArgs - if List.isEmpty bindingErrors then - let bindingArgs = List.map (function Atom (arg, _) -> arg | _ -> failwithumf ()) bindingArgs - let binding = FunctionBinding (bindingName, Array.ofList bindingArgs, this.SymbolToExpr bindingBody) - Some binding - else None - | _ -> None - - override this.CanConvertTo (_, destType) = - destType = typeof || - destType = typeof - - override this.ConvertTo (_, _, source, destType) = - if destType = typeof then - let expr = source :?> Expr - match expr with - | Violation (names, error, originOpt) -> - let violationSymbol = Atom ("violation", None) - let namesSymbol = Atom (String.concat Constants.Scripting.ViolationSeparatorStr names, None) - let errorSymbol = Atom (error, None) - Symbols ([violationSymbol; namesSymbol; errorSymbol], originOpt) :> obj - | Unit -> Symbols ([], None) :> obj - | Bool bool -> Atom (String.boolToCodeString bool, None) :> obj - | Int int -> Number (string int, None) :> obj - | Int64 int64 -> Number (String.int64ToCodeString int64, None) :> obj - | Single single -> Number (String.singleToCodeString single, None) :> obj - | Double double -> Number (String.doubleToCodeString double, None) :> obj - | String string -> Symbol.String (string, None) :> obj - | Keyword string -> Atom ((if String.isEmpty string then "nil" else string), None) :> obj - | Pluggable pluggable -> pluggable.ToSymbol () :> obj - | Tuple elems -> - let headingSymbol = Atom ((if Array.length elems = 2 then "pair" else "tuple"), None) - let elemSymbols = elems |> Array.map (fun elem -> this.ExprToSymbol elem) |> List.ofArray - Symbols (headingSymbol :: elemSymbols, None) :> obj - | Union (name, fields) -> - let nameSymbol = Atom (name, None) - let elemSymbols = fields |> Array.map this.ExprToSymbol |> List.ofArray - Symbols (nameSymbol :: elemSymbols, None) :> obj - | Option option -> - match option with - | Some value -> Symbols ([Atom ("some", None); this.ExprToSymbol value], None) :> obj - | None -> Atom ("none", None) :> obj - | Codata codata -> - this.CodataToSymbol codata :> obj - | List elems -> - let listSymbol = Atom ("list", None) - let elemSymbols = List.map this.ExprToSymbol elems - Symbols (listSymbol :: elemSymbols, None) :> obj - | Ring set -> - let ringSymbol = Atom ("ring", None) - let elemSymbols = List.map this.ExprToSymbol (Set.toList set) - Symbols (ringSymbol :: elemSymbols, None) :> obj - | Table map -> - let tableSymbol = Atom ("table", None) - let elemSymbols = - List.map (fun (key, value) -> - let keySymbol = this.ExprToSymbol key - let valueSymbol = this.ExprToSymbol value - Symbols ([keySymbol; valueSymbol], None)) - (Map.toList map) - Symbols (tableSymbol :: elemSymbols, None) :> obj - | Record (name, map, fields) -> - let recordSymbol = Atom ("record", None) - let nameSymbol = Atom (name, None) - let mapSwap = Map.ofSeqBy (fun (kvp : KeyValuePair<_, _>) -> (kvp.Value, kvp.Key)) map - let fieldSymbols = - Seq.map (fun (kvp : KeyValuePair<_, _>) -> - let key = kvp.Value - let value = fields.[kvp.Key] - let keySymbol = Atom (key, None) - let valueSymbol = this.ExprToSymbol value - Symbols ([keySymbol; valueSymbol], None)) - mapSwap - Symbols (recordSymbol :: nameSymbol :: List.ofSeq fieldSymbols, None) :> obj - | UnionUnevaled (name, fields) -> - let nameSymbol = Atom (name, None) - let elemSymbols = fields |> Array.map this.ExprToSymbol |> List.ofArray - Symbols (nameSymbol :: elemSymbols, None) :> obj - | TableUnevaled entries -> - let tableSymbol = Atom ("table", None) - let elemSymbols = - List.map (fun (key, value) -> - let keySymbol = this.ExprToSymbol key - let valueSymbol = this.ExprToSymbol value - Symbols ([keySymbol; valueSymbol], None)) - entries - Symbols (tableSymbol :: elemSymbols, None) :> obj - | RecordUnevaled (name, fields) -> - let recordSymbol = Atom ("record", None) - let nameSymbol = Atom (name, None) - let fieldSymbols = List.map (fun (name, field) -> Symbols ([Atom (name, None); this.ExprToSymbol field], None)) fields - Symbols (recordSymbol :: nameSymbol :: fieldSymbols, None) :> obj - | Binding (name, _, _, originOpt) -> - if name = "index" then Atom ("Index", originOpt) :> obj - else Atom (name, originOpt) :> obj - | TryUpdate (expr, expr2, expr3, _, originOpt) -> - let index = this.ExprsToIndex expr expr2 - let tryUpdateSymbol = Atom ("tryUpdate", None) - Symbols ([tryUpdateSymbol; index; this.ExprToSymbol expr3], originOpt) :> obj - | Update (expr, expr2, expr3, _, originOpt) -> - let index = this.ExprsToIndex expr expr2 - let updateSymbol = Atom ("update", None) - Symbols ([updateSymbol; index; this.ExprToSymbol expr3], originOpt) :> obj - | Apply (exprs, _, originOpt) -> - let exprSymbols = Array.map this.ExprToSymbol exprs - Symbols (List.ofArray exprSymbols, originOpt) :> obj - | ApplyAnd (exprs, _, originOpt) -> - let logicSymbol = Atom ("&&", None) - let exprSymbols = List.map this.ExprToSymbol (List.ofArray exprs) - Symbols (logicSymbol :: exprSymbols, originOpt) :> obj - | ApplyOr (exprs, _, originOpt) -> - let logicSymbol = Atom ("||", None) - let exprSymbols = List.map this.ExprToSymbol (List.ofArray exprs) - Symbols (logicSymbol :: exprSymbols, originOpt) :> obj - | Let (binding, body, originOpt) -> - let letSymbol = Atom ("let", None) - let bindingSymbol = this.BindingToSymbol binding - let bodySymbol = this.ExprToSymbol body - Symbols ([letSymbol; bindingSymbol; bodySymbol], originOpt) :> obj - | LetMany (bindings, body, originOpt) -> - let letSymbol = Atom ("let", None) - let bindingSymbols = List.map (fun binding -> this.BindingToSymbol binding) bindings - let bodySymbol = this.ExprToSymbol body - Symbols (letSymbol :: bindingSymbols @ [bodySymbol], originOpt) :> obj - | Fun (pars, _, body, _, _, originOpt) -> - let funSymbol = Atom ("fun", None) - let parSymbols = Array.map (fun par -> Atom (par, None)) pars - let parsSymbol = Symbols (List.ofArray parSymbols, None) - let bodySymbol = this.ExprToSymbol body - Symbols ([funSymbol; parsSymbol; bodySymbol], originOpt) :> obj - | If (condition, consequent, alternative, originOpt) -> - let ifSymbol = Atom ("if", None) - let conditionSymbol = this.ExprToSymbol condition - let consequentSymbol = this.ExprToSymbol consequent - let alternativeSymbol = this.ExprToSymbol alternative - Symbols ([ifSymbol; conditionSymbol; consequentSymbol; alternativeSymbol], originOpt) :> obj - | Match (input, cases, originOpt) -> - let matchSymbol = Atom ("match", None) - let inputSymbol = this.ExprToSymbol input - let caseSymbols = - List.map (fun (condition, consequent) -> - let conditionSymbol = this.ExprToSymbol condition - let consequentSymbol = this.ExprToSymbol consequent - Symbols ([conditionSymbol; consequentSymbol], None)) - (List.ofArray cases) - Symbols (matchSymbol :: inputSymbol :: caseSymbols, originOpt) :> obj - | Select (cases, originOpt) -> - let selectSymbol = Atom ("select", None) - let caseSymbols = - List.map (fun (condition, consequent) -> - let conditionSymbol = this.ExprToSymbol condition - let consequentSymbol = this.ExprToSymbol consequent - Symbols ([conditionSymbol; consequentSymbol], None)) - (List.ofArray cases) - Symbols (selectSymbol :: caseSymbols, originOpt) :> obj - | Try (input, cases, originOpt) -> - let trySymbol = Atom ("try", None) - let inputSymbol = this.ExprToSymbol input - let caseSymbols = - List.map (fun ((tagNames : string list), consequent) -> - let tagSymbol = Atom (String.concat Constants.Scripting.ViolationSeparatorStr tagNames, None) - let consequentSymbol = this.ExprToSymbol consequent - Symbols ([tagSymbol; consequentSymbol], None)) - cases - Symbols (trySymbol :: inputSymbol :: caseSymbols, originOpt) :> obj - | Do (exprs, originOpt) -> - let doSymbol = Atom ("do", None) - let exprSymbols = List.map this.ExprToSymbol exprs - Symbols (doSymbol :: exprSymbols, originOpt) :> obj - | Quote (expr, originOpt) -> - Symbol.Quote (this.ExprToSymbol expr, originOpt) :> obj - | Define (binding, originOpt) -> - let defineSymbol = Atom ("define", None) - Symbols (defineSymbol :: this.BindingToSymbols binding, originOpt) :> obj - elif destType = typeof then source - else failconv "Invalid ExprConverter conversion to source." None - - override this.CanConvertFrom (_, sourceType) = - sourceType = typeof || - sourceType = typeof - - override this.ConvertFrom (_, _, source) = - match source with - | :? Symbol as symbol -> - match symbol with - | Atom (str, originOpt) -> - match str with - | "true" | "True" -> Bool true :> obj - | "false" | "False" -> Bool false :> obj - | "none" | "None" -> Option None :> obj - | "nil" -> Keyword String.Empty :> obj - | "empty" -> Codata Empty :> obj - | "Index" -> Binding ("index", ref UncachedBinding, ref UnknownBindingType, originOpt) :> obj - | "NaN" -> Single Single.NaN :> obj // NOTE: can't tell the difference between a single NaN and a double NaN! - | "Infinity" -> Double Double.PositiveInfinity :> obj - | "-Infinity" -> Double Double.NegativeInfinity :> obj - | "Infinityf" -> Single Single.PositiveInfinity :> obj - | "-Infinityf" -> Single Single.NegativeInfinity :> obj - | _ -> - let firstChar = str.[0] - if firstChar = Constants.Relation.Slot || Char.IsUpper firstChar - then Keyword str :> obj - else Binding (str, ref UncachedBinding, ref UnknownBindingType, originOpt) :> obj - | Number (str, originOpt) -> - match Int32.TryParse str with - | (false, _) -> - let str = if str.EndsWith "l" || str.EndsWith "L" then str.Substring(0, str.Length - 1) else str - match Int64.TryParse str with - | (false, _) -> - if str.EndsWith "f" || str.EndsWith "F" then - let str = str.Substring(0, str.Length - 1) - match Single.TryParse str with - | (true, single) -> Single single :> obj - | (false, _) -> Violation (["InvalidForm"; "Number"], "Unexpected numeric parse failure.", originOpt) :> obj - else - let str = if str.EndsWith "d" || str.EndsWith "D" then str.Substring(0, str.Length - 1) else str - match Double.TryParse (str, Globalization.NumberStyles.Float, Globalization.CultureInfo.CurrentCulture) with - | (true, double) -> Double double :> obj - | (false, _) -> Violation (["InvalidForm"; "Number"], "Unexpected numeric parse failure.", originOpt) :> obj - | (true, int64) -> Int64 int64 :> obj - | (true, int) -> Int int :> obj - | Prime.String (str, _) -> String str :> obj - | Prime.Quote (quoted, originOpt) -> Quote (this.SymbolToExpr quoted, originOpt) :> obj - | Prime.Symbols (symbols, originOpt) -> - match symbols with - | [] -> Unit :> obj - | Atom (name, _) :: tail -> - match name with - | "&&" -> - let args = this.SymbolsToExpr tail - let breakpoint = { BreakEnabled = false; BreakCondition = Unit } - ApplyAnd (Array.ofList args, breakpoint, originOpt) :> obj - | "||" -> - let args = this.SymbolsToExpr tail - let breakpoint = { BreakEnabled = false; BreakCondition = Unit } - ApplyOr (Array.ofList args, breakpoint, originOpt) :> obj - | "violation" -> - match tail with - | [Atom (tagStr, _)] - | [Prime.String (tagStr, _)] -> - try let tagName = tagStr in Violation (tagName.Split Constants.Scripting.ViolationSeparator |> List.ofArray, "User-defined Violation.", originOpt) :> obj - with exn -> Violation (["InvalidForm"; "Violation"], "Invalid Violation form. Violation tag must be composed of 1 or more valid names.", originOpt) :> obj - | [Atom (tagStr, _); Prime.String (errorMsg, _)] - | [Prime.String (tagStr, _); Prime.String (errorMsg, _)] -> - try let tagName = tagStr in Violation (tagName.Split Constants.Scripting.ViolationSeparator |> List.ofArray, errorMsg, originOpt) :> obj - with exn -> Violation (["InvalidForm"; "Violation"], "Invalid Violation form. Violation tag must be composed of 1 or more valid names.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Violation"], "Invalid Violation form. Requires 1 tag.", originOpt) :> obj - | "table" -> - if List.forall (function Symbols ([_; _], _) -> true | _ -> false) tail then - let entries = List.map (function Symbols ([key; value], _) -> (this.SymbolToExpr key, this.SymbolToExpr value) | _ -> failwithumf ()) tail - TableUnevaled entries :> obj - else Violation (["InvalidForm"; "Table"], "Invalid Table form. Requires 1 or more field definitions.", originOpt) :> obj - | "record" -> - match tail with - | Atom (name, _) :: cases -> - if List.forall (function Symbols ([Atom _; _], _) -> true | _ -> false) cases then - let definitions = List.map (function Symbols ([Atom (fieldName, _); fieldValue], _) -> (fieldName, fieldValue) | _ -> failwithumf ()) cases - let definitions = List.map (fun (fieldName, fieldValue) -> (fieldName, this.SymbolToExpr fieldValue)) definitions - RecordUnevaled (name, definitions) :> obj - else Violation (["InvalidForm"; "Record"], "Invalid Record form. Requires 1 or more field definitions.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Record"], "Invalid Record form. Requires 1 name and 1 or more field definitions.", originOpt) :> obj - | "tryUpdate" -> - match tail with - | [index; body] -> - match this.IndexToExprs index with - | Some (indexer, target) -> - let breakpoint = { BreakEnabled = false; BreakCondition = Unit } - TryUpdate (this.SymbolToExpr indexer, this.SymbolToExpr target, this.SymbolToExpr body, breakpoint, originOpt) :> obj - | None -> - Violation (["InvalidForm"; "TryUpdate"], "Invalid tryUpdate form. Requires an index for the first argument.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "TryUpdate"], "Invalid tryUpdate form. Requires 1 index and 1 value.", originOpt) :> obj - | "update" -> - match tail with - | [index; body] -> - match this.IndexToExprs index with - | Some (indexer, target) -> - let breakpoint = { BreakEnabled = false; BreakCondition = Unit } - Update (this.SymbolToExpr indexer, this.SymbolToExpr target, this.SymbolToExpr body, breakpoint, originOpt) :> obj - | None -> - Violation (["InvalidForm"; "Update"], "Invalid update form. Requires an index for the first argument.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Update"], "Invalid update form. Requires 1 index and 1 value.", originOpt) :> obj - | "let" -> - match tail with - | [] -> Violation (["InvalidForm"; "Let"], "Invalid let form. Requires both a binding and a body.", originOpt) :> obj - | [_] -> Violation (["InvalidForm"; "Let"], "Invalid let form. Requires both a binding and a body.", originOpt) :> obj - | [binding; body] -> - match binding with - | Symbols (bindingSymbols, _) -> - match this.SymbolsToBindingOpt bindingSymbols with - | Some binding -> Let (binding, this.SymbolToExpr body, originOpt) :> obj - | None -> Violation (["InvalidForm"; "Let"], "Invalid let form. Bindings require both a name and an expression.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Let"], "Invalid let form. Bindings require both a name and an expression.", originOpt) :> obj - | bindingsAndBody -> - let (bindings, body) = (List.allButLast bindingsAndBody, List.last bindingsAndBody) - let (bindings, bindingsErrored) = List.split (function Symbols ([_; _], _) -> true | _ -> false) bindings - if List.isEmpty bindingsErrored then - let bindings = List.map (function Symbols ([_; _] as binding, _) -> binding | _ -> failwithumf ()) bindings - let bindingOpts = List.map this.SymbolsToBindingOpt bindings - let (bindingOpts, bindingErrors) = List.split Option.isSome bindingOpts - if List.isEmpty bindingErrors then - let bindings = List.definitize bindingOpts - LetMany (bindings, this.SymbolToExpr body, originOpt) :> obj - else Violation (["InvalidForm"; "Let"], "Invalid let form. Bindings require both a name and an expression.", originOpt) :> obj - else Violation (["InvalidForm"; "Let"], "Invalid let form. Bindings require both a name and an expression.", originOpt) :> obj - | "fun" -> - match tail with - | [args; body] -> - match args with - | Symbols (args, _) -> - if List.forall (function Atom _ -> true | _ -> false) args then - let args = Array.map (function Atom (arg, _) -> arg | _ -> failwithumf ()) (Array.ofList args) - Fun (args, Array.length args, this.SymbolToExpr body, false, None, originOpt) :> obj - else Violation (["InvalidForm"; "Function"], "Invalid fun form. Each argument must be a single name.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Function"], "Invalid fun form. Arguments must be enclosed in brackets.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Function"], "Invalid fun form. Fun requires 1 argument list and 1 body.", originOpt) :> obj - | "if" -> - match tail with - | [condition; consequent; alternative] -> If (this.SymbolToExpr condition, this.SymbolToExpr consequent, this.SymbolToExpr alternative, originOpt) :> obj - | _ -> Violation (["InvalidForm"; "If"], "Invalid if form. Requires 3 arguments.", originOpt) :> obj - | "match" -> - match tail with - | input :: cases -> - let input = this.SymbolToExpr input - if List.forall (function Symbols ([_; _], _) -> true | _ -> false) cases then - let cases = List.map (function Symbols ([condition; consequent], _) -> (condition, consequent) | _ -> failwithumf ()) cases - let cases = List.map (fun (condition, consequent) -> (this.SymbolToExpr condition, this.SymbolToExpr consequent)) cases - Match (input, Array.ofList cases, originOpt) :> obj - else Violation (["InvalidForm"; "Match"], "Invalid match form. Requires 1 or more cases.", originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Match"], "Invalid match form. Requires 1 input and 1 or more cases.", originOpt) :> obj - | "select" -> - let cases = tail - if List.forall (function Symbols ([_; _], _) -> true | _ -> false) cases then - let cases = List.map (function Symbols ([condition; consequent], _) -> (condition, consequent) | _ -> failwithumf ()) cases - let cases = List.map (fun (condition, consequent) -> (this.SymbolToExpr condition, this.SymbolToExpr consequent)) cases - Select (Array.ofList cases, originOpt) :> obj - else Violation (["InvalidForm"; "Select"], "Invalid select form. Requires 1 or more cases.", originOpt) :> obj - | "try" -> - match tail with - | [body; Symbols (handlers, _)] -> - let handlerEirs = - List.mapi - (fun i handler -> - match handler with - | Symbols ([Atom (categoriesStr, _); handlerBody], _) -> - Right (categoriesStr.Split Constants.Scripting.ViolationSeparator |> List.ofArray, handlerBody) - | _ -> - Left ("Invalid try handler form for handler #" + scstring (inc i) + ". Requires 1 path and 1 body.")) - handlers - let (errors, handlers) = Either.split handlerEirs - match errors with - | [] -> Try (this.SymbolToExpr body, List.map (mapSnd this.SymbolToExpr) handlers, originOpt) :> obj - | error :: _ -> Violation (["InvalidForm"; "Try"], error, originOpt) :> obj - | _ -> Violation (["InvalidForm"; "Try"], "Invalid try form. Requires 1 body and a handler list.", originOpt) :> obj - | "do" -> - match tail with - | [] -> Violation (["InvalidForm"; "Do"], "Invalid do form. Requires 1 or more sub-expressions.", originOpt) :> obj - | symbols -> - let exprs = this.SymbolsToExpr symbols - Do (exprs, originOpt) :> obj - | "define" -> - let bindingSymbols = tail - match this.SymbolsToBindingOpt bindingSymbols with - | Some binding -> Define (binding, originOpt) :> obj - | None -> Violation (["InvalidForm"; "Define"], "Invalid define form. Invalid binding.", originOpt) :> obj - | _ -> - let breakpoint = { BreakEnabled = false; BreakCondition = Unit } - Apply (Array.ofList (this.SymbolsToExpr symbols), breakpoint, originOpt) :> obj - | _ -> - let breakpoint = { BreakEnabled = false; BreakCondition = Unit } - Apply (Array.ofList (this.SymbolsToExpr symbols), breakpoint, originOpt) :> obj - | :? Expr -> source - | _ -> failconv "Invalid ExprConverter conversion from source." None - - /// The true value in scripting. - let TrueValue = Bool true - - /// The false value in scripting. - let FalseValue = Bool false - - /// The none value in scripting. - let NoneValue = Option None - - /// A declaration bindings frame in a scripting environment. - type DeclarationFrame = Dictionary - - /// A declaration bindings frame in a scripting environment. - type ProceduralFrame = (struct (string * Expr)) array - - /// The manner in which bindings are added to a frame. - type AddType = - | AddToNewFrame of Size : int - | AddToHeadFrame of Offset : int - - [] - module EnvModule = - - /// The execution environment for scripts. - type [] Env = - private - { GlobalFrame : DeclarationFrame - mutable LocalFrame : DeclarationFrame - mutable ProceduralFrames : ProceduralFrame list } - - [] - module Env = - - let private BottomBinding = - struct (String.Empty, Violation (["BottomAccess"], "Accessed a Bottom value.", None)) - - let getLocalFrame env = - env.LocalFrame - - let setLocalFrame localFrame env = - env.LocalFrame <- localFrame - - let getGlobalFrame env = - env.GlobalFrame - - let private makeProceduralFrame size = - Array.create size BottomBinding - - let private addProceduralFrame frame env = - env.ProceduralFrames <- frame :: env.ProceduralFrames - - let private tryGetDeclarationBinding name env = - match env.LocalFrame.TryGetValue name with - | (false, _) -> - match env.GlobalFrame.TryGetValue name with - | (false, _) -> None - | (true, value) -> Some value - | (true, value) -> Some value - - let private tryGetProceduralBinding name env = - let offsetRef = ref -1 - let indexOptRef = ref None - let optBinding = - List.tryFindPlus - (fun frame -> - offsetRef := !offsetRef + 1 - indexOptRef := Array.tryFindIndexBack (fun struct (bindingName, _) -> name.Equals bindingName) frame // OPTIMIZATION: faster than (=) here - match !indexOptRef with - | Some index -> Some frame.[index] - | None -> None) - env.ProceduralFrames - match optBinding with - | Some struct (_, binding) -> Some (struct (binding, !offsetRef, (!indexOptRef).Value)) - | None -> None - - let tryGetBinding name cachedBinding (_ : BindingType ref) env = - match !cachedBinding with - | UncachedBinding -> - match tryGetProceduralBinding name env with - | None -> - match tryGetDeclarationBinding name env with - | Some binding as bindingOpt -> -#if DEBUG - // NOTE: when debugging, we allow declaration bindings to be redefined, thus we can't cache... - ignore binding -#else - // ...otherwise we can cache since bindings will be immutable - cachedBinding := DeclarationBinding binding -#endif - bindingOpt - | None -> None - | Some struct (binding, offset, index) -> - cachedBinding := ProceduralBinding (offset, index) - Some binding - | DeclarationBinding binding -> - Some binding - | ProceduralBinding (offset, index) -> - let frame = (List.skip offset env.ProceduralFrames).Head - let struct (_, binding) = frame.[index] - Some binding - - let tryAddDeclarationBinding name value env = - let isTopLevel = List.isEmpty env.ProceduralFrames - if isTopLevel then - env.LocalFrame.ForceAdd (name, value) - true - else false - - let addProceduralBinding appendType name value env = - match appendType with - | AddToNewFrame size -> - let frame = makeProceduralFrame size - frame.[0] <- struct (name, value) - addProceduralFrame frame env - | AddToHeadFrame offset -> - match env.ProceduralFrames with - | frame :: _ -> frame.[offset] <- struct (name, value) - | [] -> failwithumf () - - let addProceduralBindings appendType bindings env = - match appendType with - | AddToNewFrame size -> - let frame = makeProceduralFrame size - let mutable index = 0 - for binding in bindings do - frame.[index] <- binding - index <- index + 1 - addProceduralFrame frame env - | AddToHeadFrame start -> - match env.ProceduralFrames with - | frame :: _ -> - let mutable index = start - for binding in bindings do - frame.[index] <- binding - index <- index + 1 - | [] -> failwithumf () - - let removeProceduralBindings env = - match env.ProceduralFrames with - | [] -> failwithumf () - | _ :: tail -> env.ProceduralFrames <- tail - - let getProceduralFrames env = - env.ProceduralFrames - - let setProceduralFrames proceduralFrames env = - env.ProceduralFrames <- proceduralFrames - - let make () = - // NOTE: local frame starts out the same as the global frame so that prelude - // functions are defined globally - let globalFrame = DeclarationFrame HashIdentity.Structural - { GlobalFrame = globalFrame - LocalFrame = globalFrame - ProceduralFrames = [] } - - /// The execution environment for scripts. - type Env = EnvModule.Env - - /// Attempting to expose Env module contents as well, but does not seem to work... - module Env = EnvModule.Env \ No newline at end of file diff --git a/Prime/Prime/ScriptingBinary.fs b/Prime/Prime/ScriptingBinary.fs deleted file mode 100644 index cf395defe1..0000000000 --- a/Prime/Prime/ScriptingBinary.fs +++ /dev/null @@ -1,288 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open Prime -open Prime.Scripting -module ScriptingBinary = - - type [] BinaryFns = - { Bool : bool -> bool -> SymbolOrigin option -> Expr - Int : int -> int -> SymbolOrigin option -> Expr - Int64 : int64 -> int64 -> SymbolOrigin option -> Expr - Single : single -> single -> SymbolOrigin option -> Expr - Double : double -> double -> SymbolOrigin option -> Expr - String : string -> string -> SymbolOrigin option -> Expr - Keyword : string -> string -> SymbolOrigin option -> Expr - Tuple : Expr array -> Expr array -> SymbolOrigin option -> Expr - Union : string -> Expr array -> string -> Expr array -> SymbolOrigin option -> Expr - Codata : Codata -> Codata -> SymbolOrigin option -> Expr - List : Expr list -> Expr list -> SymbolOrigin option -> Expr - Ring : Expr Set -> Expr Set -> SymbolOrigin option -> Expr - Table : Map -> Map -> SymbolOrigin option -> Expr - Record : string -> Map -> Expr array -> string -> Map -> Expr array -> SymbolOrigin option -> Expr } - - let EqFns = - { Bool = fun left right _ -> Bool (left = right) - Int = fun left right _ -> Bool (left = right) - Int64 = fun left right _ -> Bool (left = right) - Single = fun left right _ -> Bool (left = right) - Double = fun left right _ -> Bool (left = right) - String = fun left right _ -> Bool (left = right) - Keyword = fun left right _ -> Bool (left = right) - Tuple = fun left right _ -> Bool (left = right) - Union = fun keywordLeft fieldsLeft keywordRight fieldsRight _ -> Bool ((keywordLeft, fieldsLeft) = (keywordRight, fieldsRight)) - Codata = fun _ _ originOpt -> Violation (["NotImplemented"; "Eq"], "Equality not implemented for Codata.", originOpt) - List = fun left right _ -> Bool (left = right) - Ring = fun left right _ -> Bool (left = right) - Table = fun left right _ -> Bool (left = right) - Record = fun keywordLeft mapLeft fieldsLeft keywordRight mapRight fieldsRight _ -> Bool ((keywordLeft, mapLeft, fieldsLeft) = (keywordRight, mapRight, fieldsRight)) } - - let NotEqFns = - { Bool = fun left right _ -> Bool (left <> right) - Int = fun left right _ -> Bool (left <> right) - Int64 = fun left right _ -> Bool (left <> right) - Single = fun left right _ -> Bool (left <> right) - Double = fun left right _ -> Bool (left <> right) - String = fun left right _ -> Bool (left <> right) - Keyword = fun left right _ -> Bool (left <> right) - Tuple = fun left right _ -> Bool (left <> right) - Union = fun keywordLeft fieldsLeft keywordRight fieldsRight _ -> Bool ((keywordLeft, fieldsLeft) <> (keywordRight, fieldsRight)) - Codata = fun _ _ originOpt -> Violation (["NotImplemented"; "NotEq"], "Equality not implemented for Codata.", originOpt) - List = fun left right _ -> Bool (left <> right) - Ring = fun left right _ -> Bool (left <> right) - Table = fun left right _ -> Bool (left <> right) - Record = fun keywordLeft mapLeft fieldsLeft keywordRight mapRight fieldsRight _ -> Bool ((keywordLeft, mapLeft, fieldsLeft) <> (keywordRight, mapRight, fieldsRight)) } - - let LtFns = - { Bool = fun left right _ -> Bool (left < right) - Int = fun left right _ -> Bool (left < right) - Int64 = fun left right _ -> Bool (left < right) - Single = fun left right _ -> Bool (left < right) - Double = fun left right _ -> Bool (left < right) - String = fun left right _ -> Bool (left < right) - Keyword = fun left right _ -> Bool (left < right) - Tuple = fun left right _ -> Bool (left < right) - Union = fun keywordLeft fieldsLeft keywordRight fieldsRight _ -> Bool ((keywordLeft, fieldsLeft) < (keywordRight, fieldsRight)) - Codata = fun _ _ originOpt -> Violation (["NotImplemented"; "Lt"], "Comparison not implemented for Codata.", originOpt) - List = fun left right _ -> Bool (left < right) - Ring = fun left right _ -> Bool (left < right) - Table = fun left right _ -> Bool (left < right) - Record = fun keywordLeft mapLeft fieldsLeft keywordRight mapRight fieldsRight _ -> Bool ((keywordLeft, mapLeft, fieldsLeft) < (keywordRight, mapRight, fieldsRight)) } - - let GtFns = - { Bool = fun left right _ -> Bool (left > right) - Int = fun left right _ -> Bool (left > right) - Int64 = fun left right _ -> Bool (left > right) - Single = fun left right _ -> Bool (left > right) - Double = fun left right _ -> Bool (left > right) - String = fun left right _ -> Bool (left > right) - Keyword = fun left right _ -> Bool (left > right) - Tuple = fun left right _ -> Bool (left > right) - Union = fun keywordLeft fieldsLeft keywordRight fieldsRight _ -> Bool ((keywordLeft, fieldsLeft) > (keywordRight, fieldsRight)) - Codata = fun _ _ originOpt -> Violation (["NotImplemented"; "Gt"], "Comparison not implemented for Codata.", originOpt) - List = fun left right _ -> Bool (left > right) - Ring = fun left right _ -> Bool (left > right) - Table = fun left right _ -> Bool (left > right) - Record = fun keywordLeft mapLeft fieldsLeft keywordRight mapRight fieldsRight _ -> Bool ((keywordLeft, mapLeft, fieldsLeft) > (keywordRight, mapRight, fieldsRight)) } - - let LtEqFns = - { Bool = fun left right _ -> Bool (left <= right) - Int = fun left right _ -> Bool (left <= right) - Int64 = fun left right _ -> Bool (left <= right) - Single = fun left right _ -> Bool (left <= right) - Double = fun left right _ -> Bool (left <= right) - String = fun left right _ -> Bool (left <= right) - Keyword = fun left right _ -> Bool (left <= right) - Tuple = fun left right _ -> Bool (left <= right) - Union = fun keywordLeft fieldsLeft keywordRight fieldsRight _ -> Bool ((keywordLeft, fieldsLeft) <= (keywordRight, fieldsRight)) - Codata = fun _ _ originOpt -> Violation (["NotImplemented"; "LtEq"], "Comparison not implemented for Codata.", originOpt) - List = fun left right _ -> Bool (left <= right) - Ring = fun left right _ -> Bool (left <= right) - Table = fun left right _ -> Bool (left <= right) - Record = fun keywordLeft mapLeft fieldsLeft keywordRight mapRight fieldsRight _ -> Bool ((keywordLeft, mapLeft, fieldsLeft) <= (keywordRight, mapRight, fieldsRight)) } - - let GtEqFns = - { Bool = fun left right _ -> Bool (left >= right) - Int = fun left right _ -> Bool (left >= right) - Int64 = fun left right _ -> Bool (left >= right) - Single = fun left right _ -> Bool (left >= right) - Double = fun left right _ -> Bool (left >= right) - String = fun left right _ -> Bool (left >= right) - Keyword = fun left right _ -> Bool (left >= right) - Tuple = fun left right _ -> Bool (left >= right) - Union = fun keywordLeft fieldsLeft keywordRight fieldsRight _ -> Bool ((keywordLeft, fieldsLeft) >= (keywordRight, fieldsRight)) - Codata = fun _ _ originOpt -> Violation (["NotImplemented"; "GtEq"], "Comparison not implemented for Codata.", originOpt) - List = fun left right _ -> Bool (left >= right) - Ring = fun left right _ -> Bool (left >= right) - Table = fun left right _ -> Bool (left >= right) - Record = fun keywordLeft mapLeft fieldsLeft keywordRight mapRight fieldsRight _ -> Bool ((keywordLeft, mapLeft, fieldsLeft) >= (keywordRight, mapRight, fieldsRight)) } - - let AddFns = - { Bool = fun left right _ -> Bool (if left && right then false elif left then true elif right then true else false) - Int = fun left right _ -> Int (left + right) - Int64 = fun left right _ -> Int64 (left + right) - Single = fun left right _ -> Single (left + right) - Double = fun left right _ -> Double (left + right) - String = fun left right _ -> String (left + right) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Add"], "Cannot add Keywords.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Add"], "Cannot add Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Add"], "Cannot add Unions.", originOpt) - Codata = fun left right _ -> Codata (Add (left, right)) - List = fun left right _ -> List (left @ right) - Ring = fun left right _ -> Ring (Set.union left right) - Table = fun left right _ -> Table (left @@ right) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Add"], "Cannot add Records.", originOpt) } - - let SubFns = - { Bool = fun left right _ -> Bool (if left && right then false elif left then true elif right then true else false) - Int = fun left right _ -> Int (left - right) - Int64 = fun left right _ -> Int64 (left - right) - Single = fun left right _ -> Single (left - right) - Double = fun left right _ -> Double (left - right) - String = fun left right _ -> String (left.Replace (right, String.Empty)) - Keyword = fun left right _ -> String (left.Replace (right, String.Empty)) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Sub"], "Cannot subtract Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Sub"], "Cannot subtract Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Sub"], "Cannot subtract Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Sub"], "Cannot subtract Lists.", originOpt) - Ring = fun left right _ -> Ring (Set.difference left right) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Sub"], "Cannot subtract Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Sub"], "Cannot subtract Records.", originOpt) } - - let MulFns = - { Bool = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Bools.", originOpt) - Int = fun left right _ -> Int (left * right) - Int64 = fun left right _ -> Int64 (left * right) - Single = fun left right _ -> Single (left * right) - Double = fun left right _ -> Double (left * right) - String = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Strings.", originOpt) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Keyword.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Lists.", originOpt) - Ring = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Rings.", originOpt) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Mul"], "Cannot multiply Records.", originOpt) } - - let DivFns = - { Bool = fun left right originOpt -> if right = false then Violation (["OutOfRangeArgument"; "Div"], "Cannot divide by a false Bool.", originOpt) else Bool (if left && right then true else false) - Int = fun left right originOpt -> if right = 0 then Violation (["OutOfRangeArgument"; "Div"], "Cannot divide by a zero Int.", originOpt) else Int (left / right) - Int64 = fun left right originOpt -> if right = 0L then Violation (["OutOfRangeArgument"; "Div"], "Cannot divide by a zero Int64.", originOpt) else Int64 (left / right) - Single = fun left right _ -> Single (left / right) - Double = fun left right _ -> Double (left / right) - String = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Strings.", originOpt) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Keywords.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Lists.", originOpt) - Ring = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Rings.", originOpt) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Div"], "Cannot divide Records.", originOpt) } - - let ModFns = - { Bool = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Bools.", originOpt) - Int = fun left right originOpt -> if right = 0 then Violation (["OutOfRangeArgument"; "Mod"], "Cannot modulate by a zero Int.", originOpt) else Int (left % right) - Int64 = fun left right originOpt -> if right = 0L then Violation (["OutOfRangeArgument"; "Mod"], "Cannot divide by a zero Int64.", originOpt) else Int64 (left % right) - Single = fun left right _ -> Single (left % right) - Double = fun left right _ -> Double (left % right) - String = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Strings.", originOpt) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Keywords.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Lists.", originOpt) - Ring = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Rings.", originOpt) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Mod"], "Cannot modulate Records.", originOpt) } - - let PowFns = - { Bool = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Bools.", originOpt) - Int = fun left right _ -> Int (int ^ Math.Pow (double left, double right)) - Int64 = fun left right _ -> Int64 (int64 ^ Math.Pow (double left, double right)) - Single = fun left right _ -> Single (single ^ Math.Pow (double left, double right)) - Double = fun left right _ -> Double (Math.Pow (double left, double right)) - String = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Strings.", originOpt) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Keywords.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Lists.", originOpt) - Ring = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Rings.", originOpt) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Pow"], "Cannot power Records.", originOpt) } - - let RootFns = - { Bool = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Bools.", originOpt) - Int = fun left right _ -> Int (int ^ Math.Pow (double left, 1.0 / double right)) - Int64 = fun left right _ -> Int64 (int64 ^ Math.Pow (double left, 1.0 / double right)) - Single = fun left right _ -> Single (single ^ Math.Pow (double left, 1.0 / double right)) - Double = fun left right _ -> Double (Math.Pow (double left, 1.0 / double right)) - String = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Strings.", originOpt) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Keywords.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Lists.", originOpt) - Ring = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Rings.", originOpt) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Root"], "Cannot root Records.", originOpt) } - - let CrossFns = - { Bool = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Bools.", originOpt) - Int = fun left right _ -> Int (left * right) - Int64 = fun left right _ -> Int64 (left * right) - Single = fun left right _ -> Single (left * right) - Double = fun left right _ -> Double (left * right) - String = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Strings.", originOpt) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Keywords.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Lists.", originOpt) - Ring = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Rings.", originOpt) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Cross"], "Cannot cross multiply Records.", originOpt) } - - let DotFns = - { Bool = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Bools.", originOpt) - Int = fun left right _ -> Int (left * right) - Int64 = fun left right _ -> Int64 (left * right) - Single = fun left right _ -> Single (left * right) - Double = fun left right _ -> Double (left * right) - String = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Strings.", originOpt) - Keyword = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Keywords.", originOpt) - Tuple = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Tuples.", originOpt) - Union = fun _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Unions.", originOpt) - Codata = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Codata.", originOpt) - List = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Lists.", originOpt) - Ring = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Rings.", originOpt) - Table = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Tables.", originOpt) - Record = fun _ _ _ _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Dot"], "Cannot dot multiply Records.", originOpt) } - - let evalBinaryInner (fns : BinaryFns) fnName evaledLeft evaledRight originOpt (world : 'w) = - match (evaledLeft, evaledRight) with - | (Bool boolLeft, Bool boolRight) -> struct (fns.Bool boolLeft boolRight originOpt, world) - | (Int intLeft, Int intRight) -> struct (fns.Int intLeft intRight originOpt, world) - | (Int64 int64Left, Int64 int64Right) -> struct (fns.Int64 int64Left int64Right originOpt, world) - | (Single singleLeft, Single singleRight) -> struct (fns.Single singleLeft singleRight originOpt, world) - | (Double doubleLeft, Double doubleRight) -> struct (fns.Double doubleLeft doubleRight originOpt, world) - | (String stringLeft, String stringRight) -> struct (fns.String stringLeft stringRight originOpt, world) - | (Keyword keywordLeft, Keyword keywordRight) -> struct (fns.String keywordLeft keywordRight originOpt, world) - | (Tuple tupleLeft, Tuple tupleRight) -> struct (fns.Tuple tupleLeft tupleRight originOpt, world) - | (Union (nameLeft, fieldsLeft), Union (nameRight, fieldsRight)) -> struct (fns.Union nameLeft fieldsLeft nameRight fieldsRight originOpt, world) - | (Codata codataLeft, Codata codataRight) -> struct (fns.Codata codataLeft codataRight originOpt, world) - | (List listLeft, List listRight) -> struct (fns.List listLeft listRight originOpt, world) - | (Ring ringLeft, Ring ringRight) -> struct (fns.Ring ringLeft ringRight originOpt, world) - | (Table tableLeft, Table tableRight) -> struct (fns.Table tableLeft tableRight originOpt, world) - | (Violation _ as violation, _) -> struct (violation, world) - | (_, (Violation _ as violation)) -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; (String.capitalize fnName)], "Cannot apply a binary function on unlike or incompatible values.", originOpt), world) - - let evalBinary fns fnName argsEvaled originOpt (world : 'w) = - match argsEvaled with - | [|evaledLeft; evaledRight|] -> evalBinaryInner fns fnName evaledLeft evaledRight originOpt world - | _ -> struct (Violation (["InvalidArgumentCount"; (String.capitalize fnName)], "Incorrect number of arguments for application of '" + fnName + "'; 2 arguments required.", originOpt), world) \ No newline at end of file diff --git a/Prime/Prime/ScriptingMarshalling.fs b/Prime/Prime/ScriptingMarshalling.fs deleted file mode 100644 index 25b56d61aa..0000000000 --- a/Prime/Prime/ScriptingMarshalling.fs +++ /dev/null @@ -1,293 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic -open System.ComponentModel -open FSharp.Reflection -open Prime -open Prime.Scripting -#nowarn "21" -#nowarn "40" -module ScriptingMarshalling = - - let rec tryImport (tryImportExt : Type -> obj -> Expr option) (ty : Type) (value : obj) : Expr option = - - // try to import from the custom types - let ty = if ty.IsGenericTypeDefinition then ty.GetGenericTypeDefinition () else ty - match Importers.TryGetValue ty.Name with - | (true, tryImportFn) -> tryImportFn tryImportExt ty value - | (false, _) -> - - // try to import as extension value - match tryImportExt ty value with - | None -> - - // failing that, try import as Tuple - if FSharpType.IsTuple ty then - let tupleElementTypes = FSharpType.GetTupleElements ty - let tupleFields = FSharpValue.GetTupleFields value - let tupleFieldOpts = Array.mapi (fun i tupleField -> tryImport tryImportExt tupleElementTypes.[i] tupleField) tupleFields - match Array.definitizePlus tupleFieldOpts with - | (true, tupleFields) -> Some (Tuple tupleFields) - | (false, _) -> None - - // or as Record - elif FSharpType.IsRecord ty then - let recordFieldInfos = FSharpType.GetRecordFields ty - let recordFields = FSharpValue.GetRecordFields value - let recordFieldOpts = Array.mapi (fun i recordField -> tryImport tryImportExt recordFieldInfos.[i].PropertyType recordField) recordFields - match Array.definitizePlus recordFieldOpts with - | (true, recordFields) -> - let recordName = match ty.Name.IndexOf '`' with -1 -> ty.Name | index -> ty.Name.Substring (0, index) - let recordFieldMap = recordFieldInfos |> Array.mapi (fun i (field : Reflection.PropertyInfo) -> (field.Name, i)) |> Map.ofArray - Some (Record (recordName, recordFieldMap, recordFields)) - | (false, _) -> None - - // or as Union - elif FSharpType.IsUnion ty then - let (unionCase, unionFields) = FSharpValue.GetUnionFields (value, ty) - let unionFieldInfos = unionCase.GetFields () - if not ^ Array.isEmpty unionFields then - let unionFieldOpts = Array.mapi (fun i unionField -> tryImport tryImportExt unionFieldInfos.[i].PropertyType unionField) unionFields - match Array.definitizePlus unionFieldOpts with - | (true, unionFields) -> Some (Union (unionCase.Name, unionFields)) - | (false, _) -> None - else Some (Union (unionCase.Name, [||])) - - // otherwise, we have no conversion - else None - - // it's an extension value - | Some value -> Some value - - and tryImportGuid (_ : Type) (value : obj) = - Some (String ((GuidConverter ()).ConvertToString value)) - - and tryImportKeyValuePair tryImportExt (ty : Type) (value : obj) = - let gargs = ty.GetGenericArguments () - let kvp = Reflection.objToKeyValuePair value - let keyOpt = tryImport tryImportExt gargs.[0] kvp.Key - let valueOpt = tryImport tryImportExt gargs.[1] kvp.Value - match (keyOpt, valueOpt) with - | (Some key, Some value) -> Some (Tuple [|key; value|]) - | (_, _) -> None - - and tryImportAddress (ty : Type) (value : obj) = - Some (String ((AddressConverter ty).ConvertToString value)) - - and tryImportRelation (ty : Type) (value : obj) = - Some (String ((RelationConverter ty).ConvertToString value)) - - and tryImportOption tryImportExt (ty : Type) (value : obj) = - let valueType = (ty.GetGenericArguments ()).[0] - let opt = Reflection.objToOption value - match opt with - | Some value -> - match tryImport tryImportExt valueType value with - | Some value -> Some (Option (Some value)) - | None -> None - | None -> Some (Option None) - - and tryImportList tryImportExt (ty : Type) (value : obj) = - let itemType = (ty.GetGenericArguments ()).[0] - let objList = Reflection.objToObjList value - let itemOpts = List.map (fun item -> tryImport tryImportExt itemType item) objList - match List.definitizePlus itemOpts with - | (true, items) -> Some (List items) - | (false, _) -> None - - and tryImportSet tryImportExt (ty : Type) (value : obj) = - let itemType = (ty.GetGenericArguments ()).[0] - let items = Reflection.objToComparableSet value - let itemOpts = Seq.map (fun item -> tryImport tryImportExt itemType item) items - match Seq.definitizePlus itemOpts with - | (true, items) -> Some (Ring (Set.ofSeq items)) - | (false, _) -> None - - and tryImportMap tryImportExt (ty : Type) (value : obj) = - let gargs = ty.GetGenericArguments () - let itemType = typedefof>.MakeGenericType [|gargs.[0]; gargs.[1]|] - let items = Reflection.objToObjList value - let itemOpts = List.map (fun item -> tryImport tryImportExt itemType item) items - match Seq.definitizePlus itemOpts with - | (true, items) -> Some (Ring (Set.ofSeq items)) - | (false, _) -> None - - and Importers : Dictionary obj -> Expr option) -> Type -> obj -> Expr option> = - [(typeof.Name, (fun _ _ _ -> Unit |> Some)) - (typeof.Name, (fun _ _ _ -> Unit |> Some)) - (typeof.Name, (fun _ _ (value : obj) -> match value with :? bool as bool -> Some (Bool bool) | _ -> None)) - (typeof.Name, (fun _ _ (value : obj) -> match value with :? int as int -> Some (Int int) | _ -> None)) - (typeof.Name, (fun _ _ (value : obj) -> match value with :? int64 as int64 -> Some (Int64 int64) | _ -> None)) - (typeof.Name, (fun _ _ (value : obj) -> match value with :? single as single -> Some (Single single) | _ -> None)) - (typeof.Name, (fun _ _ (value : obj) -> match value with :? double as double -> Some (Double double) | _ -> None)) - (typeof.Name, (fun _ _ (value : obj) -> match value with :? char as char -> Some (String (string char)) | _ -> None)) - (typeof.Name, (fun _ _ (value : obj) -> match value with :? string as str -> Some (String str) | _ -> None)) - (typedefof.Name, (fun _ ty value -> tryImportGuid ty value)) - (typedefof>.Name, (fun tryImportExt ty value -> tryImportKeyValuePair tryImportExt ty value)) - (typedefof<_ Address>.Name, (fun _ ty value -> tryImportAddress ty value)) - (typedefof<_ Relation>.Name, (fun _ ty value -> tryImportRelation ty value)) - (typedefof<_ option>.Name, (fun tryImportExt ty value -> tryImportOption tryImportExt ty value)) - (typedefof<_ list>.Name, (fun tryImportExt ty value -> tryImportList tryImportExt ty value)) - (typedefof<_ Set>.Name, (fun tryImportExt ty value -> tryImportSet tryImportExt ty value)) - (typedefof>.Name, (fun tryImportExt ty value -> tryImportMap tryImportExt ty value))] |> - dictPlus - - let rec tryExport tryExportExt (ty : Type) (value : Expr) = - - // try to export from the custom types - match Exporters.TryGetValue ty.Name with - | (true, tryExport) -> tryExport tryExportExt ty value - | (false, _) -> - - // try to export as extension value - match tryExportExt ty value with - | None -> - - // failing that, try export as Tuple - if FSharpType.IsTuple ty then - match value with - | Tuple fields - | Union (_, fields) - | Record (_, _, fields) -> - let fieldInfos = FSharpType.GetTupleElements ty - let fieldOpts = Array.mapi (fun i fieldSymbol -> tryExport tryExportExt fieldInfos.[i] fieldSymbol) fields - match Array.definitizePlus fieldOpts with - | (true, fields) -> Some (FSharpValue.MakeTuple (fields, ty)) - | (false, _) -> None - | _ -> None - - // or as Record - elif FSharpType.IsRecord ty then - match value with - | Union (_, fields) - | Record (_, _, fields) -> - let fieldInfos = FSharpType.GetRecordFields ty - let fieldOpts = Array.mapi (fun i fieldSymbol -> tryExport tryExportExt fieldInfos.[i].PropertyType fieldSymbol) fields - match Array.definitizePlus fieldOpts with - | (true, fields) -> Some (FSharpValue.MakeRecord (ty, fields)) - | (false, _) -> None - | _ -> None - - // or as Union - elif FSharpType.IsUnion ty && ty <> typeof then - let unionCases = FSharpType.GetUnionCases ty - match value with - | Keyword name -> - match Array.tryFind (fun (unionCase : UnionCaseInfo) -> unionCase.Name = name) unionCases with - | Some unionCase -> Some (FSharpValue.MakeUnion (unionCase, [||])) - | None -> None - | Union (name, fields) - | Record (name, _, fields) -> - match Array.tryFind (fun (unionCase : UnionCaseInfo) -> unionCase.Name = name) unionCases with - | Some unionCase -> - let unionFieldInfos = unionCase.GetFields () - let unionValueOpts = Array.mapi (fun i unionSymbol -> tryExport tryExportExt unionFieldInfos.[i].PropertyType unionSymbol) fields - match Array.definitizePlus unionValueOpts with - | (true, unionValues) -> Some (FSharpValue.MakeUnion (unionCase, unionValues)) - | (false, _) -> None - | None -> None - | _ -> None - - // otherwise, we have no conversion - else None - - // it's an extension value - | Some value -> Some value - - and tryExportGuid (_ : Type) (address : Expr) = - match address with - | String str | Keyword str -> Some ((GuidConverter ()).ConvertFromString str) - | _ -> None - - and tryExportKvp tryExportExt (ty : Type) (tuple : Expr) = - match tuple with - | Tuple [|fst; snd|] -> - match ty.GetGenericArguments () with - | [|fstType; sndType|] -> - let pairType = typedefof>.MakeGenericType [|fstType; sndType|] - let fstOpt = tryExport tryExportExt fstType fst - let sndOpt = tryExport tryExportExt sndType snd - match (fstOpt, sndOpt) with - | (Some fst, Some snd) -> Some (Reflection.objsToKeyValuePair fst snd pairType) - | (_, _) -> None - | _ -> None - | _ -> None - - and tryExportAddress (ty : Type) (address : Expr) = - match address with - | String str | Keyword str -> Some ((AddressConverter ty).ConvertFromString str) - | _ -> None - - and tryExportRelation (ty : Type) (relation : Expr) = - match relation with - | String str | Keyword str -> Some ((RelationConverter ty).ConvertFromString str) - | _ -> None - - and tryExportOption tryExportExt (ty : Type) (opt : Expr) = - match opt with - | Option opt -> - match opt with - | Some value -> - let valueType = (ty.GetGenericArguments ()).[0] - match tryExport tryExportExt valueType value with - | Some value -> Some (Activator.CreateInstance (ty, [|value|])) - | None -> None - | None -> Some (None :> obj) - | _ -> None - - and tryExportList tryExportExt (ty : Type) (list : Expr) = - match list with - | List list -> - let garg = ty.GetGenericArguments () |> Array.item 0 - let itemType = if garg.IsGenericTypeDefinition then garg.GetGenericTypeDefinition () else garg - let itemOpts = List.map (fun item -> tryExport tryExportExt itemType item) list - match List.definitizePlus itemOpts with - | (true, items) -> Some (Reflection.objsToList ty items) - | (false, _) -> None - | _ -> None - - and tryExportSet tryExportExt (ty : Type) (ring : Expr) = - match ring with - | Ring set -> - let elementType = (ty.GetGenericArguments ()).[0] - let elementOpts = Seq.map (fun element -> tryExport tryExportExt elementType element) set - match Seq.definitizePlus elementOpts with - | (true, elements) -> Some (Reflection.objsToSet ty elements) - | (false, _) -> None - | _ -> None - - and tryExportMap tryExportExt (ty : Type) (table : Expr) = - match table with - | Table map -> - match ty.GetGenericArguments () with - | [|fstType; sndType|] -> - let pairType = typedefof>.MakeGenericType [|fstType; sndType|] - let pairOpts = Seq.map (fun (kvp : KeyValuePair<_, _>) -> tryExport tryExportExt pairType (Tuple [|kvp.Key; kvp.Value|])) map - match Seq.definitizePlus pairOpts with - | (true, pairs) -> Some (Reflection.pairsToMap ty pairs) - | (false, _) -> None - | _ -> None - | _ -> None - - and Exporters : Dictionary Expr -> obj option) -> Type -> Expr -> obj option> = - [(typeof.Name, fun _ _ _ -> () :> obj |> Some) - (typeof.Name, fun _ _ _ -> () :> obj |> Some) - (typeof.Name, fun _ _ evaled -> match evaled with Bool value -> value :> obj |> Some | _ -> None) - (typeof.Name, fun _ _ evaled -> match evaled with Int value -> value :> obj |> Some | _ -> None) - (typeof.Name, fun _ _ evaled -> match evaled with Int64 value -> value :> obj |> Some | _ -> None) - (typeof.Name, fun _ _ evaled -> match evaled with Single value -> value :> obj |> Some | _ -> None) - (typeof.Name, fun _ _ evaled -> match evaled with Double value -> value :> obj |> Some | _ -> None) - (typeof.Name, fun _ _ evaled -> match evaled with String value when value.Length = 1 -> value.[0] :> obj |> Some | _ -> None) - (typeof.Name, fun _ _ evaled -> match evaled with String value -> value :> obj |> Some | Keyword value -> value :> obj |> Some | _ -> None) - (typedefof.Name, fun _ ty evaled -> tryExportGuid ty evaled) - (typedefof>.Name, tryExportKvp) - (typedefof<_ Address>.Name, fun _ ty evaled -> tryExportAddress ty evaled) - (typedefof<_ Relation>.Name, fun _ ty evaled -> tryExportRelation ty evaled) - (typedefof<_ option>.Name, tryExportOption) - (typedefof<_ list>.Name, tryExportList) - (typedefof<_ Set>.Name, tryExportSet) - (typedefof>.Name, tryExportMap)] |> - dictPlus diff --git a/Prime/Prime/ScriptingPrimitives.fs b/Prime/Prime/ScriptingPrimitives.fs deleted file mode 100644 index b64e21ed69..0000000000 --- a/Prime/Prime/ScriptingPrimitives.fs +++ /dev/null @@ -1,1041 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open Prime -open Prime.Scripting -open Prime.ScriptingUnary -open Prime.ScriptingBinary -open Prime.ScriptingMarshalling -module ScriptingPrimitives = - - let evalSinglet fn fnName argsEvaled originOpt world = - match argsEvaled with - | [|evaledArg|] -> fn fnName evaledArg originOpt world - | _ -> struct (Violation (["InvalidArgumentCount"; String.capitalize fnName], "Function '" + fnName + "' requires 1 argument.", originOpt), world) - - let evalDoublet fn fnName argsEvaled originOpt world = - match argsEvaled with - | [|evaledArg; evaledArg2|] -> fn fnName evaledArg evaledArg2 originOpt world - | _ -> struct (Violation (["InvalidArgumentCount"; String.capitalize fnName], "Function '" + fnName + "' requires 2 arguments.", originOpt), world) - - let evalTriplet fn fnName argsEvaled originOpt world = - match argsEvaled with - | [|evaledArg; evaledArg2; evaledArg3|] -> fn fnName evaledArg evaledArg2 evaledArg3 originOpt world - | _ -> struct (Violation (["InvalidArgumentCount"; String.capitalize fnName], "Function '" + fnName + "' requires 3 arguments.", originOpt), world) - - let evalQuadlet fn fnName argsEvaled originOpt world = - match argsEvaled with - | [|evaledArg; evaledArg2; evaledArg3; evaledArg4|] -> fn fnName evaledArg evaledArg2 evaledArg3 evaledArg4 originOpt world - | _ -> struct (Violation (["InvalidArgumentCount"; String.capitalize fnName], "Function '" + fnName + "' requires 4 arguments.", originOpt), world) - - let evalQuintet fn fnName argsEvaled originOpt world = - match argsEvaled with - | [|evaledArg; evaledArg2; evaledArg3; evaledArg4; evaledArg5|] -> fn fnName evaledArg evaledArg2 evaledArg3 evaledArg4 evaledArg5 originOpt world - | _ -> struct (Violation (["InvalidArgumentCount"; String.capitalize fnName], "Function '" + fnName + "' requires 5 arguments.", originOpt), world) - - let evalDereference fnName evaledArg originOpt world = - match evaledArg with - | Option opt -> - match opt with - | Some value -> struct (value, world) - | None -> struct (Violation (["InvalidDereference"; String.capitalize fnName], "Function '" + fnName + "' requires some value.", originOpt), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Function '" + fnName + "' requires a Referent value.", originOpt), world) - - let evalIndexIntInner index fnName evaledArg originOpt world = - match evaledArg with - | String str -> - if index >= 0 && index < String.length str - then Right struct (String (string str.[index]), world) - else Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "String does not contain element at index " + string index + ".", originOpt), world) - | Option opt -> - match (index, opt) with - | (0, Some value) -> Right struct (value, world) - | (_, Some _) -> Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Option does not contain element at index " + string index + ".", originOpt), world) - | (_, None) -> Left struct (Violation (["InvalidIndex"; String.capitalize fnName], "Function '" + fnName + "' requires some value.", originOpt), world) - | Codata _ -> - Left struct (Violation (["NotImplemented"; String.capitalize fnName], "Function '" + fnName + "' is not implemented for Codata.", originOpt), world) - | List list -> - match List.tryItem index list with - | Some item -> Right struct (item, world) - | None -> Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "List does not contain element at index " + string index + ".", originOpt), world) - | Table map -> - match Map.tryFind (Int index) map with - | Some value -> Right struct (value, world) - | None -> Left struct (Violation (["IndexNotFound"; String.capitalize fnName], "Table does not contain entry at index " + string index + ".", originOpt), world) - | Tuple fields - | Union (_, fields) - | Record (_, _, fields) -> - if index >= 0 && index < Array.length fields - then Right struct (fields.[index], world) - else Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Structure does not contain element at index " + string index + ".", originOpt), world) - | Violation _ as violation -> Right struct (violation, world) - | _ -> Left struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Application of " + fnName + " requires an indexed value for its second argument.", originOpt), world) - - let evalIndexKeywordInner name fnName evaledArg originOpt world = - match evaledArg with - | Table map -> - match Map.tryFind (Keyword name) map with - | Some value -> Right struct (value, world) - | None -> Left struct (Violation (["InvalidIndex"; String.capitalize fnName], "Table does not contain entry with key '" + name + "'.", originOpt), world) - | Record (_, map, fields) -> - match Map.tryFind name map with - | Some index -> - if index >= 0 && index < Array.length fields - then Right struct (fields.[index], world) - else Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Record does not contain element with name '" + name + "'.", originOpt), world) - | None -> - Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Record does not contain element with name '" + name + "'.", originOpt), world) - | Violation _ as violation -> Left struct (violation, world) - | _ -> Left struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Application of " + fnName + " requires a name-indexed value for its second argument.", originOpt), world) - - let evalIndexInner fnName evaledArg evaledArg2 originOpt world = - match evaledArg with - | Int index -> evalIndexIntInner index fnName evaledArg2 originOpt world - | Keyword str -> evalIndexKeywordInner str fnName evaledArg2 originOpt world - | Violation _ as violation -> Left struct (violation, world) - | _ -> - match evaledArg2 with - | Table map -> - match Map.tryFind evaledArg map with - | Some value -> Right struct (value, world) - | None -> Left struct (Violation (["InvalidIndex"; String.capitalize fnName], "Table does not contain entry with key '" + scstring evaledArg + "'.", originOpt), world) - | _ -> Left struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Application of " + fnName + " with non-String / non-Keyword indexes only applicable on Tables.", originOpt), world) - - let evalTryIndex fnName evaledArg evaledArg2 originOpt world = - match evalIndexInner fnName evaledArg evaledArg2 originOpt world with - | Right struct (evaled, world) -> struct (Option (Some evaled), world) - | Left struct (_, world) -> struct (Option None, world) - - let evalHasIndex fnName evaledArg evaledArg2 originOpt world = - match evalIndexInner fnName evaledArg evaledArg2 originOpt world with - | Right struct (_, world) -> struct (Bool true, world) - | Left struct (_, world) -> struct (Bool false, world) - - let evalIndexInt index fnName evaledArg originOpt world = - let eir = evalIndexIntInner index fnName evaledArg originOpt world - Either.amb eir - - let evalIndexKeyword index fnName evaledArg originOpt world = - let eir = evalIndexKeywordInner index fnName evaledArg originOpt world - Either.amb eir - - let evalIndex fnName evaledArg evaledArg2 originOpt world = - match evalIndexInner fnName evaledArg evaledArg2 originOpt world with - | Right success -> success - | Left error -> error - - let evalNth fnName evaledArg evaledArg2 originOpt world = - match evaledArg with - | Int index -> evalIndexInt index fnName evaledArg2 originOpt world - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Application of '" + fnName + "'requires an Int as its first argument.", originOpt), world) - - let evalGetTypeName _ evaledArg _ world = - match evaledArg with - | Violation _ as error -> struct (error, world) - | Unit _ -> struct (String "Unit", world) - | Bool _ -> struct (String "Bool", world) - | Int _ -> struct (String "Int", world) - | Int64 _ -> struct (String "Int64", world) - | Single _ -> struct (String "Single", world) - | Double _ -> struct (String "Double", world) - | String _ -> struct (String "String", world) - | Keyword _ -> struct (String "Keyword", world) - | Pluggable pluggable -> struct (String pluggable.TypeName, world) - | Tuple _ -> struct (String "Tuple", world) - | Union _ -> struct (String "Union", world) - | Option _ -> struct (String "Option", world) - | Codata _ -> struct (String "Codata", world) - | List _ -> struct (String "List", world) - | Ring _ -> struct (String "Ring", world) - | Table _ -> struct (String "Table", world) - | Record _ -> struct (String "Record", world) - | Fun _ -> struct (String "Function", world) - | Quote _ -> struct (String "Quote", world) - | _ -> failwithumf () - - let evalGetName fnName evaledArg originOpt world = - match evaledArg with - | Union (name, _) -> struct (String name, world) - | Record (name, _, _) -> struct (String name, world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Application of " + fnName + " requires a Union or Record value.", originOpt), world) - - let evalTuple _ argsEvaled _ world = - struct (Tuple argsEvaled, world) - - let evalPair _ (_ : string) evaledArg evaledArg2 world = - struct (Tuple [|evaledArg; evaledArg2|], world) - - let evalSome _ evaledArg _ world = - struct (Option (Some evaledArg), world) - - let evalIsNone fnName evaledArg originOpt world = - match evaledArg with - | Option evaled -> struct (Bool (Option.isNone evaled), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-Option.", originOpt), world) - - let evalIsSome fnName evaledArg originOpt world = - match evaledArg with - | Option evaled -> struct (Bool (Option.isSome evaled), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-Option.", originOpt), world) - - let evalCodata fnName evaledArg evaledArg2 originOpt world = - match evaledArg with - | Binding _ as binding -> struct (Codata (Unfold (binding, evaledArg2)), world) // evaled expr to binding implies extrinsic or intrinsic function - | Fun _ as fn -> struct (Codata (Unfold (fn, evaledArg2)), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "First argument to " + fnName + " must be a Function.", originOpt), world) - - let rec evalCodataTryUncons evalApply fnName originOpt codata world = - match codata with - | Empty -> Right (Left world) - | Add (left, right) -> - match evalCodataTryUncons evalApply fnName originOpt left world with - | Right (Right struct (_, _, _)) as success -> success - | Right (Left world) -> evalCodataTryUncons evalApply fnName originOpt right world - | Left _ as error -> error - | Unfold (unfolder, state) -> - match evalApply [|unfolder; state|] originOpt world with - | struct (Option (Some state), world) -> Right (Right struct (state, Unfold (unfolder, state), world)) - | struct (Option None, world) -> Right (Left world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s unfolder must return an Option.", originOpt), world) - | Conversion (head :: []) -> Right (Right struct (head, Empty, world)) - | Conversion (head :: tail) -> Right (Right struct (head, Conversion tail, world)) - | Conversion [] -> Right (Left world) - - let rec evalCodataIsEmpty evalApply fnName originOpt codata world = - match evalCodataTryUncons evalApply fnName originOpt codata world with - | Right (Right struct (_, _, world)) -> Right struct (false, world) - | Right (Left world) -> Right struct (true, world) - | Left error -> Left error - - let evalIsEmpty evalApply fnName evaledArg originOpt world = - match evaledArg with - | Bool bool -> struct (Bool (not bool), world) - | Int int -> struct (Bool (int = 0), world) - | Int64 int64 -> struct (Bool (int64 = 0L), world) - | Single single -> struct (Bool (single = 0.0f), world) - | Double double -> struct (Bool (double = 0.0), world) - | String str -> struct (Bool (String.isEmpty str), world) - | Keyword str -> struct (Bool (String.isEmpty str), world) - | Union (str, _) -> struct (Bool (String.isEmpty str), world) - | Option opt -> struct (Bool (Option.isNone opt), world) - | Codata codata -> - match evalCodataIsEmpty evalApply fnName originOpt codata world with - | Right struct (empty, world) -> struct (Bool empty, world) - | Left error -> error - | List list -> struct (Bool (List.isEmpty list), world) - | Ring set -> struct (Bool (Set.isEmpty set), world) - | Table map -> struct (Bool (Map.isEmpty map), world) - | Record (str, _, _) -> struct (Bool (String.isEmpty str), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalNotEmpty evalApply fnName evaledArg originOpt world = - match evaledArg with - | Bool bool -> struct (Bool bool, world) - | Int int -> struct (Bool (int <> 0), world) - | Int64 int64 -> struct (Bool (int64 <> 0L), world) - | Single single -> struct (Bool (single <> 0.0f), world) - | Double double -> struct (Bool (double <> 0.0), world) - | String str -> struct (Bool (String.notEmpty str), world) - | Keyword str -> struct (Bool (String.notEmpty str), world) - | Union (str, _) -> struct (Bool (String.notEmpty str), world) - | Option opt -> struct (Bool (Option.isSome opt), world) - | Codata codata -> - match evalCodataIsEmpty evalApply fnName originOpt codata world with - | Right struct (empty, world) -> struct (Bool (not empty), world) - | Left error -> error - | List list -> struct (Bool (List.notEmpty list), world) - | Ring set -> struct (Bool (Set.notEmpty set), world) - | Table map -> struct (Bool (Map.notEmpty map), world) - | Record (str, _, _) -> struct (Bool (String.notEmpty str), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalTryUnconsInner evalApply fnName evaledArg originOpt world = - match evaledArg with - | String str -> - if String.notEmpty str - then Right (Right struct (String (string str.[0]), String (str.Substring 1), world)) - else Right (Left world) - | Option opt -> - match opt with - | Some value -> Right (Right struct (value, NoneValue, world)) - | None -> Right (Left world) - | Codata codata -> - match evalCodataTryUncons evalApply fnName originOpt codata world with - | Right (Right struct (head, tail, world)) -> Right (Right struct (head, Codata tail, world)) - | Right (Left world) -> Right (Left world) - | Left error -> Left error - | List list -> - match list with - | [] -> Right (Left world) - | head :: tail -> Right (Right struct (head, List tail, world)) - | Ring set -> - match Seq.tryHead set with - | Some head -> Right (Right struct (head, Ring (Set.remove head set), world)) - | None -> Right (Left world) - | Table map -> - match Seq.tryHead map with - | Some kvp -> Right (Right struct (Tuple [|kvp.Key; kvp.Value|], Table (Map.remove kvp.Key map), world)) - | None -> Right (Left world) - | Violation _ as violation -> Left struct (violation, world) - | _ -> Left struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalTryUncons evalApply fnName evaledArg originOpt world = - match evalTryUnconsInner evalApply fnName evaledArg originOpt world with - | Right (Right struct (head, tail, world)) -> struct (Option (Some (Tuple [|head; tail|])), world) - | Right (Left world) -> struct (Option None, world) - | Left error -> error - - let evalUncons evalApply fnName evaledArg originOpt world = - match evalTryUnconsInner evalApply fnName evaledArg originOpt world with - | Right (Right struct (head, tail, world)) -> struct (Tuple [|head; tail|], world) - | Right (Left world) -> struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Cannot apply " + fnName + " to an empty container.", originOpt), world) - | Left error -> error - - let evalCons fnName evaledArg evaledArg2 originOpt world = - match (evaledArg, evaledArg2) with - | (evaledArg, String str) -> - match evaledArg with - | String head when String.length head = 1 -> struct (String (head + str), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Incorrect number of arguments for application of '" + fnName + "'; 2 string arguments required where the first is of length 1.", originOpt), world) - | (evaledArg, Option opt) -> - match opt with - | Some _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot cons onto some value.", originOpt), world) - | None -> struct (Option (Some evaledArg), world) - | (evaledArg, List list) -> - struct (List (evaledArg :: list), world) - | (evaledArg, Codata codata) -> - match codata with - | Empty -> struct (Codata (Conversion [evaledArg]), world) - | Add _ -> struct (Codata (Add (Conversion [evaledArg], codata)), world) - | Unfold _ -> struct (Codata (Add (Conversion [evaledArg], codata)), world) - | Conversion list -> struct (Codata (Conversion (evaledArg :: list)), world) - | (evaledArg, Ring set) -> - struct (Ring (Set.add evaledArg set), world) - | (evaledArg, Table map) -> - match evaledArg with - | Tuple elems when Array.length elems = 2 -> struct (Table (Map.add elems.[0] elems.[1] map), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Table entry must consist of a pair.", originOpt), world) - | (Violation _ as violation, _) -> struct (violation, world) - | (_, (Violation _ as violation)) -> struct (violation, world) - | (_, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-List.", originOpt), world) - - let evalCommit fnName evaledArg originOpt world = - match evaledArg with - | Option _ -> struct (evaledArg, world) - | Codata _ -> struct (evaledArg, world) - | List list -> struct (List (List.rev list), world) - | Ring _ -> struct (evaledArg, world) - | Table _ -> struct (evaledArg, world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalTryHead evalApply fnName argsEvaled originOpt world = - match evalTryUnconsInner evalApply fnName argsEvaled originOpt world with - | Right (Right struct (head, _, world)) -> struct (head, world) - | Right (Left world) -> struct (Option None, world) - | Left error -> error - - let evalHead evalApply fnName argsEvaled originOpt world = - match evalTryUnconsInner evalApply fnName argsEvaled originOpt world with - | Right (Right struct (head, _, world)) -> struct (head, world) - | Right (Left world) -> struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Cannot apply " + fnName + " to a container with no elements.", originOpt), world) - | Left error -> error - - let evalTryTail evalApply fnName argsEvaled originOpt world = - match evalTryUnconsInner evalApply fnName argsEvaled originOpt world with - | Right (Right struct (_, tail, world)) -> struct (tail, world) - | Right (Left world) -> struct (Option None, world) - | Left error -> error - - let evalTail evalApply fnName argsEvaled originOpt world = - match evalTryUnconsInner evalApply fnName argsEvaled originOpt world with - | Right (Right struct (_, tail, world)) -> struct (tail, world) - | Right (Left world) -> struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Cannot apply " + fnName + " to a container with no elements.", originOpt), world) - | Left error -> error - - let rec evalScanWhileCodata evalApply fnName originOpt scanner state codata world = - match codata with - | Empty -> - Right struct (state, [], world) - | Add (left, right) -> - match evalScanWhileCodata evalApply fnName originOpt scanner state left world with - | Right struct (state, statesLeft, world) -> - match evalScanWhileCodata evalApply fnName originOpt scanner state right world with - | Right struct (state, statesRight, world) -> Right struct (state, statesRight @ statesLeft, world) - | error -> error - | error -> error - | Unfold (unfolder, costate) -> - match evalApply [|unfolder; costate|] originOpt world with - | struct (Option (Some costate), world) -> - match evalApply [|scanner; state; costate|] originOpt world with - | struct (Option (Some state), world) -> evalScanWhileCodata evalApply fnName originOpt scanner state (Unfold (unfolder, costate)) world - | struct (Option None, world) -> Right struct (state, [], world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world) - | struct (Option None, world) -> Right struct (state, [], world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s unfolder must return an Option.", originOpt), world) - | Conversion list -> - Seq.foldWhileRight (fun struct (state, states, world) elem -> - match evalApply [|scanner; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, state :: states, world)) - | struct (Option None, world) -> Left struct (List states, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world)) - (Right struct (state, [], world)) - list - - let rec evalScaniCodata evalApply fnName originOpt i scanner state codata world = - match codata with - | Empty -> - Right struct (i, state, [], world) - | Add (left, right) -> - match evalScaniCodata evalApply fnName originOpt (inc i) scanner state left world with - | Right struct (i, state, statesLeft, world) -> - match evalScaniCodata evalApply fnName originOpt (inc i) scanner state right world with - | Right struct (i, state, statesRight, world) -> Right struct (i, state, statesRight @ statesLeft, world) - | error -> error - | error -> error - | Unfold (unfolder, costate) -> - match evalApply [|unfolder; costate|] originOpt world with - | struct (Option (Some costate), world) -> - match evalApply [|scanner; Int i; state; costate|] originOpt world with - | struct (Violation _, _) as error -> Left error - | struct (state, world) -> evalScaniCodata evalApply fnName originOpt (inc i) scanner state (Unfold (unfolder, costate)) world - | struct (Option None, world) -> Right struct (i, state, [], world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s unfolder must return an Option.", originOpt), world) - | Conversion list -> - Seq.foldWhileRight (fun struct (i, state, states, world) elem -> - match evalApply [|scanner; Int i; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (inc i, state, state :: states, world)) - | struct (Option None, world) -> Left struct (List states, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world)) - (Right struct (i, state, [], world)) - list - - let rec evalScanCodata evalApply fnName originOpt scanner state codata world = - match codata with - | Empty -> - Right struct (state, [], world) - | Add (left, right) -> - match evalScanCodata evalApply fnName originOpt scanner state left world with - | Right struct (state, statesLeft, world) -> - match evalScanCodata evalApply fnName originOpt scanner state right world with - | Right struct (state, statesRight, world) -> Right struct (state, statesRight @ statesLeft, world) - | error -> error - | error -> error - | Unfold (unfolder, costate) -> - match evalApply [|unfolder; costate|] originOpt world with - | struct (Option (Some costate), world) -> - match evalApply [|scanner; state; costate|] originOpt world with - | struct (Violation _, _) as error -> Left error - | struct (state, world) -> evalScanCodata evalApply fnName originOpt scanner state (Unfold (unfolder, costate)) world - | struct (Option None, world) -> Right struct (state, [], world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s unfolder must return an Option.", originOpt), world) - | Conversion list -> - Seq.foldWhileRight (fun struct (state, states, world) elem -> - match evalApply [|scanner; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, state :: states, world)) - | struct (Option None, world) -> Left struct (List states, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world)) - (Right struct (state, [], world)) - list - - let evalScanWhile evalApply fnName evaledArg evaledArg2 evaledArg3 originOpt world = - match (evaledArg, evaledArg2, evaledArg3) with - | (scanner, state, String str) -> - match - Seq.foldWhileRight (fun struct (state, states, world) elem -> - match evalApply [|scanner; state; String (string elem)|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, state :: states, world)) - | struct (Option None, world) -> Left struct (List states, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world)) - (Right struct (state, [], world)) - str with - | Right struct (_, states, world) -> struct (List (List.rev states), world) - | Left error -> error - | (scanner, state, Codata codata) -> - match evalScanWhileCodata evalApply fnName originOpt scanner state codata world with - | Right struct (_, states, world) -> struct (List (List.rev states), world) - | Left error -> error - | (scanner, state, List list) -> - match - Seq.foldWhileRight (fun struct (state, states, world) elem -> - match evalApply [|scanner; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, state :: states, world)) - | struct (Option None, world) -> Left struct (List states, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world)) - (Right struct (state, [], world)) - list with - | Right struct (_, states, world) -> struct (List (List.rev states), world) - | Left error -> error - | (scanner, state, Ring set) -> - match - Seq.foldWhileRight (fun struct (state, states, world) elem -> - match evalApply [|scanner; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, state :: states, world)) - | struct (Option None, world) -> Left struct (List states, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world)) - (Right struct (state, [], world)) - set with - | Right struct (_, states, world) -> struct (List (List.rev states), world) - | Left error -> error - | (scanner, state, Table map) -> - match - Seq.foldWhileRight (fun struct (state, states, world) (key, value) -> - let entry = Tuple [|key; value|] - match evalApply [|scanner; state; entry|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, state :: states, world)) - | struct (Option None, world) -> Left struct (List states, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s scanner must return an Option.", originOpt), world)) - (Right struct (state, [], world)) - (Map.toList map) with - | Right struct (_, states, world) -> struct (List (List.rev states), world) - | Left error -> error - | (Violation _ as error, _, _) -> struct (error, world) - | (_, (Violation _ as error), _) -> struct (error, world) - | (_, _, (Violation _ as error)) -> struct (error, world) - | (_, _, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalScani evalApply fnName evaledArg evaledArg2 evaledArg3 originOpt world = - match (evaledArg, evaledArg2, evaledArg3) with - | (scanner, state, String str) -> - let struct (_, states, world) = - Seq.foldi (fun i struct (state, states, world) elem -> - let struct (state, world) = evalApply [|scanner; Int i; state; String (string elem)|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - str - struct (List (List.rev states), world) - | (scanner, state, Codata codata) -> - match evalScaniCodata evalApply fnName originOpt 0 scanner state codata world with - | Right struct (_, _, states, world) -> struct (List (List.rev states), world) - | Left error -> error - | (scanner, state, List list) -> - let struct (_, states, world) = - Seq.foldi (fun i struct (state, states, world) elem -> - let struct (state, world) = evalApply [|scanner; Int i; state; elem|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - list - struct (List (List.rev states), world) - | (scanner, state, Ring set) -> - let struct (_, states, world) = - Seq.foldi (fun i struct (state, states, world) elem -> - let struct (state, world) = evalApply [|scanner; Int i; state; elem|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - set - struct (List (List.rev states), world) - | (scanner, state, Table map) -> - let struct (_, states, world) = - Seq.foldi (fun i struct (state, states, world) (key, value) -> - let entry = Tuple [|key; value|] - let struct (state, world) = evalApply [|scanner; Int i; state; entry|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - (Map.toList map) - struct (List (List.rev states), world) - | (Violation _ as error, _, _) -> struct (error, world) - | (_, (Violation _ as error), _) -> struct (error, world) - | (_, _, (Violation _ as error)) -> struct (error, world) - | (_, _, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalScan evalApply fnName evaledArg evaledArg2 evaledArg3 originOpt world = - match (evaledArg, evaledArg2, evaledArg3) with - | (scanner, state, String str) -> - let struct (_, states, world) = - Seq.fold (fun struct (state, states, world) elem -> - let struct (state, world) = evalApply [|scanner; state; String (string elem)|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - str - struct (List (List.rev states), world) - | (scanner, state, Codata codata) -> - match evalScanCodata evalApply fnName originOpt scanner state codata world with - | Right struct (_, states, world) -> struct (List (List.rev states), world) - | Left error -> error - | (scanner, state, List list) -> - let struct (_, states, world) = - Seq.fold (fun struct (state, states, world) elem -> - let struct (state, world) = evalApply [|scanner; state; elem|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - list - struct (List (List.rev states), world) - | (scanner, state, Ring set) -> - let struct (_, states, world) = - Seq.fold (fun struct (state, states, world) elem -> - let struct (state, world) = evalApply [|scanner; state; elem|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - set - struct (List (List.rev states), world) - | (scanner, state, Table map) -> - let struct (_, states, world) = - Seq.fold (fun struct (state, states, world) (key, value) -> - let entry = Tuple [|key; value|] - let struct (state, world) = evalApply [|scanner; state; entry|] originOpt world - struct (state, state :: states, world)) - struct (state, [], world) - (Map.toList map) - struct (List (List.rev states), world) - | (Violation _ as error, _, _) -> struct (error, world) - | (_, (Violation _ as error), _) -> struct (error, world) - | (_, _, (Violation _ as error)) -> struct (error, world) - | (_, _, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let rec evalFoldWhileCodata evalApply fnName originOpt folder state codata world = - match codata with - | Empty -> - Right struct (state, world) - | Add (left, right) -> - match evalFoldWhileCodata evalApply fnName originOpt folder state left world with - | Right struct (state, world) -> evalFoldWhileCodata evalApply fnName originOpt folder state right world - | error -> error - | Unfold (unfolder, costate) -> - match evalApply [|unfolder; costate|] originOpt world with - | struct (Option (Some costate), world) -> - match evalApply [|folder; state; costate|] originOpt world with - | struct (Option (Some state), world) -> evalFoldWhileCodata evalApply fnName originOpt folder state (Unfold (unfolder, costate)) world - | struct (Option None, world) -> Right struct (state, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world) - | struct (Option None, world) -> Right struct (state, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s unfolder must return an Option.", originOpt), world) - | Conversion list -> - Seq.foldWhileRight (fun struct (state, world) elem -> - match evalApply [|folder; state; elem|] originOpt world with - | struct (Option (Some state), world) -> Right struct (state, world) - | struct (Option None, world) -> Left struct (state, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world)) - (Right struct (state, world)) - list - - let rec evalFoldiCodata evalApply fnName originOpt i folder state codata world = - match codata with - | Empty -> - Right struct (i, state, world) - | Add (left, right) -> - match evalFoldiCodata evalApply fnName originOpt (inc i) folder state left world with - | Right struct (i, state, world) -> - match evalFoldiCodata evalApply fnName originOpt (inc i) folder state right world with - | Right struct (i, state, world) -> Right struct (i, state, world) - | error -> error - | error -> error - | Unfold (unfolder, costate) -> - match evalApply [|unfolder; costate|] originOpt world with - | struct (Option (Some costate), world) -> - match evalApply [|folder; Int i; state; costate|] originOpt world with - | struct (Violation _, _) as error -> Left error - | struct (state, world) -> evalFoldiCodata evalApply fnName originOpt (inc i) folder state (Unfold (unfolder, costate)) world - | struct (Option None, world) -> Right struct (i, state, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s unfolder must return an Option.", originOpt), world) - | Conversion list -> - Seq.foldWhileRight (fun struct (i, state, world) elem -> - match evalApply [|folder; Int i; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (inc i, state, world)) - | struct (Option None, world) -> Left struct (state, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world)) - (Right struct (i, state, world)) - list - - let rec evalFoldCodata evalApply fnName originOpt folder state codata world = - match codata with - | Empty -> - Right struct (state, world) - | Add (left, right) -> - match evalFoldCodata evalApply fnName originOpt folder state left world with - | Right struct (state, world) -> - match evalFoldCodata evalApply fnName originOpt folder state right world with - | Right struct (state, world) -> Right struct (state, world) - | error -> error - | error -> error - | Unfold (unfolder, costate) -> - match evalApply [|unfolder; costate|] originOpt world with - | struct (Option (Some costate), world) -> - match evalApply [|folder; state; costate|] originOpt world with - | struct (Violation _, _) as error -> Left error - | struct (state, world) -> evalFoldCodata evalApply fnName originOpt folder state (Unfold (unfolder, costate)) world - | struct (Option None, world) -> Right struct (state, world) - | struct (Violation _, _) as error -> Left error - | struct (_, world) -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s unfolder must return an Option.", originOpt), world) - | Conversion list -> - Seq.foldWhileRight (fun struct (state, world) elem -> - match evalApply [|folder; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, world)) - | struct (Option None, world) -> Left struct (state, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world)) - (Right struct (state, world)) - list - - let evalFoldWhile evalApply fnName evaledArg evaledArg2 evaledArg3 originOpt world = - match (evaledArg, evaledArg2, evaledArg3) with - | (folder, state, String str) -> - let eir = - Seq.foldWhileRight (fun struct (state, world) elem -> - match evalApply [|folder; state; String (string elem)|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, world)) - | struct (Option None, world) -> Left struct (state, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world)) - (Right struct (state, world)) - str - Either.amb eir - | (folder, state, Codata codata) -> - match evalFoldWhileCodata evalApply fnName originOpt folder state codata world with - | Right success -> success - | Left error -> error - | (folder, state, List list) -> - let eir = - Seq.foldWhileRight (fun struct (state, world) elem -> - match evalApply [|folder; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, world)) - | struct (Option None, world) -> Left struct (state, world) - | struct (Violation _, _) as error -> Left error - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world)) - (Right struct (state, world)) - list - Either.amb eir - | (folder, state, Ring set) -> - let eir = - Seq.foldWhileRight (fun struct (state, world) elem -> - match evalApply [|folder; state; elem|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, world)) - | struct (Option None, world) -> Left struct (state, world) - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world)) - (Right struct (state, world)) - set - Either.amb eir - | (folder, state, Table map) -> - let eir = - Seq.foldWhileRight (fun struct (state, world) (key, value) -> - let entry = Tuple [|key; value|] - match evalApply [|folder; state; entry|] originOpt world with - | struct (Option (Some state), world) -> (Right struct (state, world)) - | struct (Option None, world) -> Left struct (state, world) - | _ -> Left struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s folder must return an Option.", originOpt), world)) - (Right struct (state, world)) - (Map.toList map) - Either.amb eir - | (Violation _ as error, _, _) -> struct (error, world) - | (_, (Violation _ as error), _) -> struct (error, world) - | (_, _, (Violation _ as error)) -> struct (error, world) - | (_, _, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalFoldi evalApply fnName evaledArg evaledArg2 evaledArg3 originOpt world = - match (evaledArg, evaledArg2, evaledArg3) with - | (folder, state, String str) -> Seq.foldi (fun i struct (state, world) elem -> evalApply [|folder; Int i; state; String (string elem)|] originOpt world) struct (state, world) str - | (folder, state, Codata codata) -> - match evalFoldiCodata evalApply fnName originOpt 0 folder state codata world with - | Right struct (_, state, world) -> struct (state, world) - | Left error -> error - | (folder, state, List list) -> Seq.foldi (fun i struct (state, world) elem -> evalApply [|folder; Int i; state; elem|] originOpt world) struct (state, world) list - | (folder, state, Ring set) -> Seq.foldi (fun i struct (state, world) elem -> evalApply [|folder; Int i; state; elem|] originOpt world) struct (state, world) set - | (folder, state, Table map) -> - Seq.foldi (fun i struct (state, world) (key, value) -> - let entry = Tuple [|key; value|] - evalApply [|folder; Int i; state; entry|] originOpt world) - struct (state, world) - (Map.toList map) - | (_, _, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalFold evalApply fnName evaledArg evaledArg2 evaledArg3 originOpt world = - match (evaledArg, evaledArg2, evaledArg3) with - | (folder, state, String str) -> Seq.fold (fun struct (state, world) elem -> evalApply [|folder; state; String (string elem)|] originOpt world) struct (state, world) str - | (folder, state, Codata codata) -> - match evalFoldCodata evalApply fnName originOpt folder state codata world with - | Right struct (state, world) -> struct (state, world) - | Left error -> error - | (folder, state, List list) -> List.fold (fun struct (state, world) elem -> evalApply [|folder; state; elem|] originOpt world) struct (state, world) list - | (folder, state, Ring set) -> Set.fold (fun struct (state, world) elem -> evalApply [|folder; state; elem|] originOpt world) struct (state, world) set - | (folder, state, Table map) -> - Map.fold (fun struct (state, world) key value -> - let entry = Tuple [|key; value|] - evalApply [|folder; state; entry|] originOpt world) - struct (state, world) - map - | (Violation _ as error, _, _) -> struct (error, world) - | (_, (Violation _ as error), _) -> struct (error, world) - | (_, _, (Violation _ as error)) -> struct (error, world) - | (_, _, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let rec evalMapCodata evalApply originOpt mapper codata (world : 'w) : struct (Codata * 'w) = - match codata with - | Empty -> - struct (codata, world) - | Add (left, right) -> - let struct (leftMapped, world) = evalMapCodata evalApply originOpt mapper left world - let struct (rightMapped, world) = evalMapCodata evalApply originOpt mapper right world - struct (Add (leftMapped, rightMapped), world) - | Unfold (unfolder, codata) -> - let breakpoint = { BreakEnabled = false; BreakCondition = Unit } - let args = [|unfolder; Binding ("state", ref UncachedBinding, ref Environmental, originOpt)|] - let unfolder = Unfold (Fun ([|"state"|], 1, Apply (args, breakpoint, originOpt), false, None, originOpt), codata) - struct (unfolder, world) - | Conversion list -> - let struct (mapped, world) = - List.fold (fun struct (elems, world) elem -> - let struct (elem, world) = evalApply [|mapper; elem|] originOpt world - struct (elem :: elems, world)) - struct ([], world) - list - struct (Conversion (List.rev mapped), world) - - let evalMapi evalApply fnName evaledArg evaledArg2 originOpt world = - match (evaledArg, evaledArg2) with - | (mapper, (Option opt as option)) -> - match opt with - | Some value -> evalApply [|mapper; Int 0; value|] originOpt world - | None -> struct (option, world) - | (mapper, String str) -> - let (list, world) = - str |> - Seq.foldi (fun i (elems, world) elem -> - let elem = String (string elem) - let struct (elem, world) = evalApply [|mapper; Int i; elem|] originOpt world - (elem :: elems, world)) - ([], world) - if List.forall (function String str when String.length str = 1 -> true | _ -> false) list - then struct (String (list |> List.rev |> List.map (function String str -> str.[0] | _ -> failwithumf ()) |> String.implode), world) - else struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s mapper must return a String of length 1.", originOpt), world) - | (mapper, Codata codata) -> - let struct (codata, world) = evalMapCodata evalApply originOpt mapper codata world - struct (Codata codata, world) - | (mapper, List list) -> - let struct (list, world) = - Seq.foldi (fun i struct (elems, world) elem -> - let struct (elem, world) = evalApply [|mapper; Int i; elem|] originOpt world - struct (elem :: elems, world)) - struct ([], world) - list - struct (List (List.rev list), world) - | (mapper, Ring set) -> - let struct (set, world) = - Seq.foldi (fun i struct (elems, world) elem -> - let struct (elem, world) = evalApply [|mapper; Int i; elem|] originOpt world - struct (Set.add elem elems, world)) - struct (Set.empty, world) - set - struct (Ring set, world) - | (mapper, Table map) -> - let struct (map, world) = - Seq.foldi (fun i struct (elems, world) (key, value) -> - let entry = Tuple [|key; value|] - let struct (entry, world) = evalApply [|mapper; Int i; entry|] originOpt world - match entry with - | Tuple elems' when Array.length elems' = 2 -> struct (Map.add elems'.[0] elems'.[1] elems, world) - | _ -> struct (elems, world)) - struct (Map.empty, world) - (Map.toList map) - struct (Table map, world) - | (Violation _ as error, _) -> struct (error, world) - | (_, (Violation _ as error)) -> struct (error, world) - | (_, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalMap evalApply fnName evaledArg evaledArg2 originOpt world = - match (evaledArg, evaledArg2) with - | (mapper, (Option opt as option)) -> - match opt with - | Some value -> evalApply [|mapper; value|] originOpt world - | None -> struct (option, world) - | (mapper, String str) -> - let struct (list, world) = - str |> - Seq.fold (fun struct (elems, world) elem -> - let elem = String (string elem) - let struct (elem, world) = evalApply [|mapper; elem|] originOpt world - struct (elem :: elems, world)) - struct ([], world) - if List.forall (function String str when String.length str = 1 -> true | _ -> false) list - then struct (String (list |> List.rev |> List.map (function String str -> str.[0] | _ -> failwithumf ()) |> String.implode), world) - else struct (Violation (["InvalidResult"; String.capitalize fnName], "Function " + fnName + "'s mapper must return a String of length 1.", originOpt), world) - | (mapper, Codata codata) -> - let struct (codata, world) = evalMapCodata evalApply originOpt mapper codata world - struct (Codata codata, world) - | (mapper, List list) -> - let struct (list, world) = - List.fold (fun struct (elems, world) elem -> - let struct (elem, world) = evalApply [|mapper; elem|] originOpt world - struct (elem :: elems, world)) - struct ([], world) - list - struct (List (List.rev list), world) - | (mapper, Ring set) -> - let struct (set, world) = - Set.fold (fun struct (elems, world) elem -> - let struct (elem, world) = evalApply [|mapper; elem|] originOpt world - struct (Set.add elem elems, world)) - struct (Set.empty, world) - set - struct (Ring set, world) - | (mapper, Table map) -> - let struct (map, world) = - Map.fold (fun struct (elems, world) key value -> - let entry = Tuple [|key; value|] - let struct (entry, world) = evalApply [|mapper; entry|] originOpt world - match entry with - | Tuple elems' when Array.length elems' = 2 -> struct (Map.add elems'.[0] elems'.[1] elems, world) - | _ -> struct (elems, world)) - struct (Map.empty, world) - map - struct (Table map, world) - | (Violation _ as error, _) -> struct (error, world) - | (_, (Violation _ as error)) -> struct (error, world) - | (_, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let rec evalContainsCodata evalApply fnName evaledArg originOpt codata world = - match codata with - | Empty -> Right struct (false, world) - | Add (left, right) -> - match evalContainsCodata evalApply fnName evaledArg originOpt left world with - | Right struct (false, world) -> evalContainsCodata evalApply fnName evaledArg originOpt right world - | Right struct (true, _) as success -> success - | Left _ as error -> error - | Unfold (unfolder, state) -> - match evalApply [|unfolder; state|] originOpt world with - | struct (Option (Some state), world) -> - if state <> evaledArg then - let codata = Unfold (unfolder, state) - evalContainsCodata evalApply fnName evaledArg originOpt codata world - else Right struct (true, world) - | struct (Option None, world) -> Right struct (false, world) - | error -> Left error - | Conversion list -> - Right struct (List.contains evaledArg list, world) - - let evalContains evalApply fnName evaledArg evaledArg2 originOpt world = - match (evaledArg, evaledArg2) with - | (evaledArg, String str) -> - match evaledArg with - | String str' -> struct (Bool (str.Contains str'), world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "First argument to " + fnName + " for a String must also be a String.", originOpt), world) - | (evaledArg, Option opt) -> struct (Bool (match opt with Some value -> value = evaledArg | None -> false), world) - | (evaledArg, Codata codata) -> - match evalContainsCodata evalApply fnName evaledArg originOpt codata world with - | Right struct (bool, world) -> struct (Bool bool, world) - | Left error -> error - | (evaledArg, List list) -> struct (Bool (List.contains evaledArg list), world) - | (evaledArg, Ring set) -> struct (Bool (Set.contains evaledArg set), world) - | (Violation _ as error, _) -> struct (error, world) - | (_, (Violation _ as error)) -> struct (error, world) - | (_, _) -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalToString fnName evaledArg originOpt world = - match evaledArg with - | String _ as str -> struct (str, world) - | List list -> - if List.forall (function String str when str.Length = 1 -> true | _ -> false) list then - let chars = List.map (function String str -> str | _ -> failwithumf ()) list - struct (String (String.Join ("", chars)), world) - else struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Function " + fnName + " cannot only be applied to single character strings.", originOpt), world) - | Ring set -> - if Set.forall (function String str when str.Length = 1 -> true | _ -> false) set then - let chars = Seq.map (function String str -> str | _ -> failwithumf ()) set - struct (String (String.Join ("", chars)), world) - else struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Function " + fnName + " cannot only be applied to single character strings.", originOpt), world) - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalToCodata fnName evaledArg originOpt world = - match evaledArg with - | Option opt -> struct (Codata (Conversion (match opt with Some value -> [value] | None -> [])), world) - | Codata _ -> struct (evaledArg, world) - | List list -> struct (Codata (Conversion list), world) - | Ring set -> struct (Codata (Conversion (Set.toList set)), world) - | Table map -> struct (Codata (Conversion (Map.toListBy (fun key value -> Tuple [|key; value|]) map)), world) - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalList _ argsEvaled _ world = - struct (List (List.ofArray argsEvaled), world) - - let rec evalCodataToList evalApply fnName originOpt list codata world = - match evalCodataTryUncons evalApply fnName originOpt codata world with - | Right (Right struct (head, tail, world)) -> evalCodataToList evalApply fnName originOpt (head :: list) tail world - | Right (Left world) -> Right (Left struct (list, world)) - | Left struct (error, world) -> Left (struct (error, world)) - - let evalToList evalApply fnName evaledArg originOpt world = - match evaledArg with - | String str -> struct (List (str |> Seq.map (string >> String) |> List.ofSeq), world) - | Option opt -> struct (List (match opt with Some value -> [value] | None -> []), world) - | Codata codata -> - match evalCodataToList evalApply fnName originOpt [] codata world with - | Right (Right struct (_, _, list, world)) -> struct (List (List.rev list), world) - | Right (Left struct (list, world)) -> struct (List (List.rev list), world) - | Left error -> error - | List _ as list -> struct (list, world) - | Ring set -> struct (List (List.ofSeq set), world) - | Table map -> struct (List (map |> Map.toListBy (fun k v -> Tuple [|k; v|])), world) - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalRing _ argsEvaled _ world = - struct (Ring (Set.ofArray argsEvaled), world) - - let evalToRing evalApply fnName evaledArg originOpt world = - match evaledArg with - | String str -> struct (Ring (str |> Seq.map (string >> String) |> Set.ofSeq), world) - | Option opt -> struct (Ring (match opt with Some value -> Set.singleton value | None -> Set.empty), world) - | Codata codata -> - match evalCodataToList evalApply fnName originOpt [] codata world with - | Right (Right struct (_, _, list, world)) -> struct (Ring (Set.ofList list), world) - | Right (Left struct (list, world)) -> struct (Ring (Set.ofList list), world) - | Left error -> error - | List list -> struct (Ring (Set.ofList list), world) - | Ring _ as ring -> struct (ring, world) - | Table map -> struct (Ring (map |> Map.toSeqBy (fun k v -> Tuple [|k; v|]) |> Set.ofSeq), world) - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-container.", originOpt), world) - - let evalRemove fnName evaledArg evaledArg2 originOpt world = - match (evaledArg, evaledArg2) with - | (value, container) -> - match container with - | Ring set -> struct (Ring (Set.remove value set), world) - | Table map -> struct (Table (Map.remove value map), world) - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Incorrect type of argument for application of '" + fnName + "'; target must be a container.", originOpt), world) - - let evalToTable fnName evaledArg originOpt world = - match evaledArg with - | List list -> - if List.forall (function Tuple [|_; _|] -> true | _ -> false) list then - let pairs = List.map (function Tuple [|k; v|] -> (k, v) | _ -> failwithumf ()) list - struct (Table (Map.ofList pairs), world) - else struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Function " + fnName + " cannot only be applied to container of pairs.", originOpt), world) - | Ring set -> - if Set.forall (function Tuple [|_; _|] -> true | _ -> false) set then - let pairs = Seq.map (function Tuple [|k; v|] -> (k, v) | _ -> failwithumf ()) set - struct (Table (Map.ofSeq pairs), world) - else struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Function " + fnName + " cannot only be applied to container of pairs.", originOpt), world) - | Table _ as table -> struct (table, world) - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["InvalidArgumentType"; String.capitalize fnName], "Cannot apply " + fnName + " to a non-string or non-container.", originOpt), world) \ No newline at end of file diff --git a/Prime/Prime/ScriptingTests.fs b/Prime/Prime/ScriptingTests.fs deleted file mode 100644 index bae719d7cf..0000000000 --- a/Prime/Prime/ScriptingTests.fs +++ /dev/null @@ -1,66 +0,0 @@ -// Nu Game Engine. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime.Tests -open System -open Xunit -open Prime -module ScriptingTests = - - type [] TestWorld = - { ScriptingEnv : Scripting.Env } - interface TestWorld ScriptingWorld with - member this.GetEnv () = this.ScriptingEnv - member this.TryGetExtrinsic _ = failwithumf () - member this.TryImport _ _ = failwithnie () - member this.TryExport _ _ = failwithnie () - static member make () = { ScriptingEnv = Scripting.EnvModule.Env.make () } - - let evalPartial exprStr = - let world = TestWorld.make () - match ScriptingWorld.tryEvalScript id Constants.Scripting.PreludeFilePath world with - | Right struct (_, _, world) -> - let expr = scvalue exprStr - ScriptingWorld.eval expr world |> fst' - | Left _ -> - Assert.True false - Scripting.Unit - - let eval exprStr = - let converter = SymbolicConverter (true, None, typeof) - let evaled = evalPartial exprStr - let evaledSymbol = converter.ConvertTo (evaled, typeof) :?> Symbol - Symbol.toString evaledSymbol - - let [] keywordsWork () = Assert.Equal ("Keyword", eval "Keyword") - let [] plusWorks () = Assert.Equal ("2", eval "[+ 1 1]") - let [] equalityWorks () = Assert.Equal ("true", eval "[= 1 1]") - let [] nestedApplicationWorks () = Assert.Equal ("4", eval "[+ [+ 1 1] [+ 1 1]]") - let [] optionsWork () = Assert.Equal ("true", eval "[isSome [some 1]]") - let [] tuplesWork () = Assert.Equal ("1", eval "[fst [tuple 1]]") - let [] listsWork () = Assert.Equal ("1", eval "[head [list 1]]") - let [] unionsWork () = Assert.Equal ("1", eval "[fst [U 1]]") - let [] recordsWork () = Assert.Equal ("1", eval "[fst [record R [F 1]]]") - let [] conditionalWorks () = Assert.Equal ("1", eval "[if [= 1 1] 1 0]") - let [] matchWorks () = Assert.Equal ("2", eval "[match 1 [0 0] [1 2]]") - let [] selectWorks () = Assert.Equal ("1", eval "[select [false 0] [true 1]]") - let [] letWorks () = Assert.Equal ("2", eval "[let [x 1] [+ x x]]") - let [] letManyWorks () = Assert.Equal ("3", eval "[let [x 1] [y 2] [+ x y]]") - let [] letFxWorks () = Assert.Equal ("1", eval "[let [f [x] x] [f 1]]") - let [] letFunWorks () = Assert.Equal ("1", eval "[let [f [fun [x] x]] [f 1]]") - let [] doWorks () = Assert.Equal ("4", eval "[do [+ 1 1] [+ 2 2]]") - - let [] matchFailureWorks () = - match evalPartial "[match 2 [0 0] [1 2]]" with - | Scripting.Violation (_, _, _) -> Assert.True true - | _ -> Assert.True false - - let [] selectFailureWorks () = - match evalPartial "[select [false 0] [false 1]]" with - | Scripting.Violation (_, _, _) -> Assert.True true - | _ -> Assert.True false - - let [] outOfRangeWorks () = - match evalPartial "[fst empty]" with - | Scripting.Violation _ -> Assert.True true - | _ -> Assert.True false \ No newline at end of file diff --git a/Prime/Prime/ScriptingUnary.fs b/Prime/Prime/ScriptingUnary.fs deleted file mode 100644 index ae6ad715c1..0000000000 --- a/Prime/Prime/ScriptingUnary.fs +++ /dev/null @@ -1,537 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open Prime -open Prime.Scripting -module ScriptingUnary = - - type [] UnaryFns = - { Bool : bool -> SymbolOrigin option -> Expr - Int : int -> SymbolOrigin option -> Expr - Int64 : int64 -> SymbolOrigin option -> Expr - Single : single -> SymbolOrigin option -> Expr - Double : double -> SymbolOrigin option -> Expr - String : string -> SymbolOrigin option -> Expr - Keyword : string -> SymbolOrigin option -> Expr - Tuple : Expr array -> SymbolOrigin option -> Expr - Union : string -> Expr array -> SymbolOrigin option -> Expr - Codata : Codata -> SymbolOrigin option -> Expr - List : Expr list -> SymbolOrigin option -> Expr - Ring : Expr Set -> SymbolOrigin option -> Expr - Table : Map -> SymbolOrigin option -> Expr - Record : string -> Map -> Expr array -> SymbolOrigin option -> Expr } - - let HashFns = - { Bool = fun value _ -> Int (hash value) - Int = fun value _ -> Int (hash value) - Int64 = fun value _ -> Int (hash value) - Single = fun value _ -> Int (hash value) - Double = fun value _ -> Int (hash value) - String = fun value _ -> Int (hash value) - Keyword = fun value _ -> Int (hash value) - Tuple = fun value _ -> Int (hash value) - Union = fun name fields _ -> Int (hash (name, fields)) - Codata = fun value _ -> Int (hash value) - List = fun value _ -> Int (hash value) - Ring = fun value _ -> Int (hash value) - Table = fun value _ -> Int (hash value) - Record = fun name map fields _ -> Int (hash (name, map, fields)) } - - let ToEmptyFns = - { Bool = fun _ _ -> Bool false - Int = fun _ _ -> Int 0 - Int64 = fun _ _ -> Int64 0L - Single = fun _ _ -> Single 0.0f - Double = fun _ _ -> Double 0.0 - String = fun _ _ -> String String.Empty - Keyword = fun _ _ -> Keyword String.Empty - Tuple = fun _ _ -> Tuple Array.empty - Union = fun _ _ _ -> Union (String.Empty, Array.empty) - Codata = fun _ _ -> Codata Empty - List = fun _ _ -> List [] - Ring = fun _ _ -> Ring Set.empty - Table = fun _ _ -> Table Map.empty - Record = fun _ _ _ _ -> Record (String.Empty, Map.empty, Array.empty) } - - let ToIdentityFns = - { Bool = fun _ _ -> Bool true - Int = fun _ _ -> Int 1 - Int64 = fun _ _ -> Int64 1L - Single = fun _ _ -> Single 1.0f - Double = fun _ _ -> Double 1.0 - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a String to an identity representation.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a Keyword to an identity representation.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a Tuple to an identity representation.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a Union to an identity representation.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert Codata to an identity representation.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a List to an identity representation.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a Ring to an identity representation.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a Table to an identity representation.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "ToIdentity"], "Cannot convert a Record to an identity representation.", originOpt) } - - let ToMinFns = - { Bool = fun _ _ -> Bool false - Int = fun _ _ -> Int Int32.MinValue - Int64 = fun _ _ -> Int64 Int64.MinValue - Single = fun _ _ -> Single Single.MinValue - Double = fun _ _ -> Double Double.MinValue - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a String to a minimum representation.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a Keyword to a minimum representation.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a Tuple to a minimum representation.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a Union to a minimum representation.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert Codata to a minimum representation.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a List to a minimum representation.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a Ring to a minimum representation.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a Table to a minimum representation.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "ToMin"], "Cannot convert a Record to an minimum representation.", originOpt) } - - let ToMaxFns = - { Bool = fun _ _ -> Bool true - Int = fun _ _ -> Int Int32.MaxValue - Int64 = fun _ _ -> Int64 Int64.MaxValue - Single = fun _ _ -> Single Single.MaxValue - Double = fun _ _ -> Double Double.MaxValue - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a String to a maximum representation.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a Keyword to a maximum representation.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a Tuple to a maximum representation.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a Union to a maximum representation.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert Codata to a maximum representation.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a List to a maximum representation.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a Ring to a maximum representation.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a Table to a maximum representation.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "ToMax"], "Cannot convert a Record to an maximum representation.", originOpt) } - - let IncFns = - { Bool = fun value _ -> Bool (if value then false else true) - Int = fun value _ -> Int (inc value) - Int64 = fun value _ -> Int64 (inc value) - Single = fun value _ -> Single (inc value) - Double = fun value _ -> Double (inc value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Inc"], "Cannot increment a Record.", originOpt) } - - let DecFns = - { Bool = fun value _ -> Bool (if value then false else true) - Int = fun value _ -> Int (dec value) - Int64 = fun value _ -> Int64 (dec value) - Single = fun value _ -> Single (dec value) - Double = fun value _ -> Double (dec value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Dec"], "Cannot decrement a Record.", originOpt) } - - let NegateFns = - { Bool = fun value _ -> Bool (if value then false else true) - Int = fun value _ -> Int (0 - value) - Int64 = fun value _ -> Int64 (0L - value) - Single = fun value _ -> Single (0.0f - value) - Double = fun value _ -> Double (0.0 - value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Negate"], "Cannot negate a Record.", originOpt) } - - let SqrFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a Bool.", originOpt) - Int = fun value _ -> Int (value * value) - Int64 = fun value _ -> Int64 (value * value) - Single = fun value _ -> Single (value * value) - Double = fun value _ -> Double (value * value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Sqr"], "Cannot square a Record.", originOpt) } - - let SqrtFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Sqrt (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Sqrt (double value)) - Single = fun value _ -> Single (single ^ Math.Sqrt (double value)) - Double = fun value _ -> Double (Math.Sqrt value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sqtr"], "Cannot square root a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Sqrt"], "Cannot square root a Record.", originOpt) } - - let FloorFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Floor (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Floor (double value)) - Single = fun value _ -> Single (single ^ Math.Floor (double value)) - Double = fun value _ -> Double (Math.Floor value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Floor"], "Cannot floor a Record.", originOpt) } - - let CeilingFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Ceiling (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Ceiling (double value)) - Single = fun value _ -> Single (single ^ Math.Ceiling (double value)) - Double = fun value _ -> Double (Math.Ceiling value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Ceiling"], "Cannot get ceiling of a Record.", originOpt) } - - let TruncateFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Truncate (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Truncate (double value)) - Single = fun value _ -> Single (single ^ Math.Truncate (double value)) - Double = fun value _ -> Double (Math.Truncate value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Truncate"], "Cannot truncate a Record.", originOpt) } - - let ExpFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Exp (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Exp (double value)) - Single = fun value _ -> Single (single ^ Math.Exp (double value)) - Double = fun value _ -> Double (Math.Exp value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Exp"], "Cannot exponentiate a Record.", originOpt) } - - let RoundFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Round (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Round (double value)) - Single = fun value _ -> Single (single ^ Math.Round (double value)) - Double = fun value _ -> Double (Math.Round value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Round"], "Cannot round a Record.", originOpt) } - - let LogFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a Bool.", originOpt) - Int = fun value originOpt -> if value = 0 then Violation (["OutOfRangeArgument"; "Log"], "Cannot log a zero Int.", originOpt) else Int (int ^ Math.Log (double value)) - Int64 = fun value originOpt -> if value = 0L then Violation (["OutOfRangeArgument"; "Log"], "Cannot log a zero Int64.", originOpt) else Int64 (int64 ^ Math.Log (double value)) - Single = fun value originOpt -> if value = 0.0f then Violation (["OutOfRangeArgument"; "Log"], "Cannot log a zero Single.", originOpt) else Single (single ^ Math.Log (double value)) - Double = fun value originOpt -> if value = 0.0 then Violation (["OutOfRangeArgument"; "Log"], "Cannot log a zero Double.", originOpt) else Double (Math.Log value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Log"], "Cannot log a Record.", originOpt) } - - let SinFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Sin (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Sin (double value)) - Single = fun value _ -> Single (single ^ Math.Sin (double value)) - Double = fun value _ -> Double (Math.Sin value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Sin"], "Cannot sin a Record.", originOpt) } - - let CosFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Cos (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Cos (double value)) - Single = fun value _ -> Single (single ^ Math.Cos (double value)) - Double = fun value _ -> Double (Math.Cos value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Cos"], "Cannot cos a Record.", originOpt) } - - let TanFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Tan (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Tan (double value)) - Single = fun value _ -> Single (single ^ Math.Tan (double value)) - Double = fun value _ -> Double (Math.Tan value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Tan"], "Cannot tan a Record.", originOpt) } - - let AsinFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Asin (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Asin (double value)) - Single = fun value _ -> Single (single ^ Math.Asin (double value)) - Double = fun value _ -> Double (Math.Asin value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Asin"], "Cannot asin a Record.", originOpt) } - - let AcosFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Acos (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Acos (double value)) - Single = fun value _ -> Single (single ^ Math.Acos (double value)) - Double = fun value _ -> Double (Math.Acos value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Acos"], "Cannot acos a Record.", originOpt) } - - let AtanFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a Bool.", originOpt) - Int = fun value _ -> Int (int ^ Math.Atan (double value)) - Int64 = fun value _ -> Int64 (int64 ^ Math.Atan (double value)) - Single = fun value _ -> Single (single ^ Math.Atan (double value)) - Double = fun value _ -> Double (Math.Atan value) - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Atan"], "Cannot atan a Record.", originOpt) } - - let LengthFns = - { Bool = fun value _ -> Int (if value then 1 else 0) - Int = fun value _ -> Int (Math.Abs value) - Int64 = fun value _ -> Int64 (Math.Abs value) - Single = fun value _ -> Single (Math.Abs value) - Double = fun value _ -> Double (Math.Abs value) - String = fun value _ -> Int (value.Length) - Keyword = fun value _ -> Int (value.Length) - Tuple = fun value _ -> Int (Array.length value) - Union = fun _ fields _ -> Int (Array.length fields) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Length"], "Cannot get length of Codata.", originOpt) - List = fun value _ -> Int (List.length value) - Ring = fun value _ -> Int (value.Count) - Table = fun value _ -> Int (value.Count) - Record = fun _ _ fields _ -> Int (Array.length fields) } - - let NormalFns = - { Bool = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a Bool.", originOpt) - Int = fun value originOpt -> if value = 0 then Violation (["OutOfRangeArgument"; "Normal"], "Cannot get the normal of a zero Int.", originOpt) elif value < 0 then Int -1 else Int 1 - Int64 = fun value originOpt -> if value = 0L then Violation (["OutOfRangeArgument"; "Normal"], "Cannot get the normal of a zero Int64.", originOpt) elif value < 0L then Int64 -1L else Int64 1L - Single = fun value originOpt -> if value = 0.0f then Violation (["OutOfRangeArgument"; "Normal"], "Cannot get the normal of a zero Single.", originOpt) elif value < 0.0f then Single -1.0f else Single 1.0f - Double = fun value originOpt -> if value = 0.0 then Violation (["OutOfRangeArgument"; "Normal"], "Cannot get the normal of a zero Double.", originOpt) elif value < 0.0 then Double -1.0 else Double 1.0 - String = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a String.", originOpt) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a Keyword.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a Tuple.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a Union.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize Codata.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a List.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a Ring.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a Table.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Normal"], "Cannot normalize a Record.", originOpt) } - - let BoolFns = - { Bool = fun value _ -> Bool (value) - Int = fun value _ -> Bool (value = 0) - Int64 = fun value _ -> Bool (value = 0L) - Single = fun value _ -> Bool (value = 0.0f) - Double = fun value _ -> Bool (value = 0.0) - String = fun value _ -> Bool (scvalue value) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert a Keyword to a Bool.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert a Tuple to a Bool.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert a Union to a Bool.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert Codata to a Bool.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert a List to a Bool.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert a Ring to a Bool.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert a Table to a Bool.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Bool"], "Cannot convert a Record to a Bool.", originOpt) } - - let IntFns = - { Bool = fun value _ -> Int (if value then 1 else 0) - Int = fun value _ -> Int (value) - Int64 = fun value _ -> Int (int value) - Single = fun value _ -> Int (int value) - Double = fun value _ -> Int (int value) - String = fun value _ -> Int (scvalue value) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert a Keyword to an Int.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert a Tuple to an Int.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert a Union to an Int.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert Codata to an Int.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert a List to an Int.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert a Ring to an Int.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert a Table to an Int.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Int"], "Cannot convert a Record to an Int.", originOpt) } - - let Int64Fns = - { Bool = fun value _ -> Int64 (if value then 1L else 0L) - Int = fun value _ -> Int64 (int64 value) - Int64 = fun value _ -> Int64 (value) - Single = fun value _ -> Int64 (int64 value) - Double = fun value _ -> Int64 (int64 value) - String = fun value _ -> Int64 (scvalue value) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert a Keyword to an Int64.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert a Tuple to an Int64.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert a Union to an Int64.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert Codata to an Int64.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert a List to an Int64.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert a Ring to an Int64.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert a Table to an Int64.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Int64"], "Cannot convert a Record to an Int64.", originOpt) } - - let SingleFns = - { Bool = fun value _ -> Single (if value then 1.0f else 0.0f) - Int = fun value _ -> Single (single value) - Int64 = fun value _ -> Single (single value) - Single = fun value _ -> Single (value) - Double = fun value _ -> Single (single value) - String = fun value _ -> Single (scvalue value) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert a Keyword to a Single.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert a Tuple to a Single.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert a Union to a Single.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert Codata to a Single.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert a List to a Single.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert a Ring to a Single.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert a Table to a Single.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Single"], "Cannot convert a Record to a Single.", originOpt) } - - let DoubleFns = - { Bool = fun value _ -> Double (if value then 1.0 else 0.0) - Int = fun value _ -> Double (double value) - Int64 = fun value _ -> Double (double value) - Single = fun value _ -> Double (double value) - Double = fun value _ -> Double (value) - String = fun value _ -> Double (scvalue value) - Keyword = fun _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert a Keyword to a Double.", originOpt) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert a Tuple to a Double.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert a Union to a Double.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert Codata to a Double.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert a List to a Double.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert a Ring to a Double.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert a Table to a Double.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "Double"], "Cannot convert a Record to a Double.", originOpt) } - - let StringFns = - { Bool = fun value _ -> String (scstring value) - Int = fun value _ -> String (scstring value) - Int64 = fun value _ -> String (scstring value) - Single = fun value _ -> String (scstring value) - Double = fun value _ -> String (scstring value) - String = fun value _ -> String (value) - Keyword = fun value _ -> String (value) - Tuple = fun _ originOpt -> Violation (["InvalidArgumentType"; "String"], "Cannot convert a Tuple to a String.", originOpt) - Union = fun _ _ originOpt -> Violation (["InvalidArgumentType"; "String"], "Cannot convert a Union to a String.", originOpt) - Codata = fun _ originOpt -> Violation (["InvalidArgumentType"; "String"], "Cannot convert Codata to a String.", originOpt) - List = fun _ originOpt -> Violation (["InvalidArgumentType"; "String"], "Cannot convert a List to a String.", originOpt) - Ring = fun _ originOpt -> Violation (["InvalidArgumentType"; "String"], "Cannot convert a Ring to a String.", originOpt) - Table = fun _ originOpt -> Violation (["InvalidArgumentType"; "String"], "Cannot convert a Table to a String.", originOpt) - Record = fun _ _ _ originOpt -> Violation (["InvalidArgumentType"; "String"], "Cannot convert a Record to a String.", originOpt) } - - let evalBoolUnary fn fnName argsEvaled originOpt (world : 'w) = - match argsEvaled with - | [|evaledArg|] -> - match evaledArg with - | Bool bool -> struct (Bool (fn bool), world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; (String.capitalize fnName)], "Cannot apply a Bool function to a non-Bool value.", originOpt), world) - | _ -> struct (Violation (["InvalidArgumentCount"; (String.capitalize fnName)], "Incorrect number of arguments for application of '" + fnName + "'; 1 argument required.", originOpt), world) - - let evalUnaryInner (fns : UnaryFns) fnName evaledArg originOpt (world : 'w) = - match evaledArg with - | Bool bool -> struct (fns.Bool bool originOpt, world) - | Int int -> struct (fns.Int int originOpt, world) - | Int64 int64 -> struct (fns.Int64 int64 originOpt, world) - | Single single -> struct (fns.Single single originOpt, world) - | Double double -> struct (fns.Double double originOpt, world) - | String string -> struct (fns.String string originOpt, world) - | Keyword keyword -> struct (fns.Keyword keyword originOpt, world) - | Tuple tuple -> struct (fns.Tuple tuple originOpt, world) - | Union (name, union) -> struct (fns.Union name union originOpt, world) - | Codata codata -> struct (fns.Codata codata originOpt, world) - | List list -> struct (fns.List list originOpt, world) - | Ring ring -> struct (fns.Ring ring originOpt, world) - | Table table -> struct (fns.Table table originOpt, world) - | Record (name, map, fields) -> struct (fns.Record name map fields originOpt, world) - | Violation _ as violation -> struct (violation, world) - | _ -> struct (Violation (["InvalidArgumentType"; (String.capitalize fnName)], "Cannot apply an unary function on an incompatible value.", originOpt), world) - - let evalUnary fns fnName argsEvaled originOpt (world : 'w) = - match argsEvaled with - | [|evaledArg|] -> evalUnaryInner fns fnName evaledArg originOpt world - | _ -> struct (Violation (["InvalidArgumentCount"; (String.capitalize fnName)], "Incorrect number of arguments for application of '" + fnName + "'; 1 argument required.", originOpt), world) \ No newline at end of file diff --git a/Prime/Prime/ScriptingWorld.fs b/Prime/Prime/ScriptingWorld.fs deleted file mode 100644 index 6fd08dd08d..0000000000 --- a/Prime/Prime/ScriptingWorld.fs +++ /dev/null @@ -1,628 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic -open System.Diagnostics -open System.IO -open Prime -open Prime.Scripting -open Prime.ScriptingUnary -open Prime.ScriptingBinary -open Prime.ScriptingMarshalling -open Prime.ScriptingPrimitives - -/// The context in which scripting takes place. Effectively a mix-in for the 'w type, where 'w is a type that -/// represents the client program. -type 'w ScriptingWorld = - interface - abstract member GetEnv : unit -> Env - abstract member TryGetExtrinsic : string -> (string -> Expr array -> SymbolOrigin option -> 'w -> struct (Expr * 'w)) FOption - abstract member TryImport : Type -> obj -> Expr option - abstract member TryExport : Type -> Expr -> obj option - end - -[] -module ScriptingWorld = - - let mutable private Intrinsics = - Unchecked.defaultof - - let inline annotateWorld<'w when 'w :> 'w ScriptingWorld> (_ : 'w) = - () // NOTE: simply infers that a type is a world. - - let tryGetBinding<'w when 'w :> 'w ScriptingWorld> name cachedBinding bindingType (world : 'w) = - Env.tryGetBinding name cachedBinding bindingType (world.GetEnv ()) - - let tryAddDeclarationBinding<'w when 'w :> 'w ScriptingWorld> name value (world : 'w) = - Env.tryAddDeclarationBinding name value (world.GetEnv ()) - - let addProceduralBinding<'w when 'w :> 'w ScriptingWorld> appendType name value (world : 'w) = - Env.addProceduralBinding appendType name value (world.GetEnv ()) - - let addProceduralBindings<'w when 'w :> 'w ScriptingWorld> appendType bindings (world : 'w) = - Env.addProceduralBindings appendType bindings (world.GetEnv ()) - - let removeProceduralBindings<'w when 'w :> 'w ScriptingWorld> (world : 'w) = - Env.removeProceduralBindings (world.GetEnv ()) - - let getProceduralFrames<'w when 'w :> 'w ScriptingWorld> (world : 'w) = - Env.getProceduralFrames (world.GetEnv ()) - - let setProceduralFrames<'w when 'w :> 'w ScriptingWorld> proceduralFrames (world : 'w) = - Env.setProceduralFrames proceduralFrames (world.GetEnv ()) - - let getGlobalFrame<'w when 'w :> 'w ScriptingWorld> (world : 'w) = - Env.getGlobalFrame (world.GetEnv ()) - - let getLocalFrame<'w when 'w :> 'w ScriptingWorld> (world : 'w) = - Env.getLocalFrame (world.GetEnv ()) - - let setLocalFrame<'w when 'w :> 'w ScriptingWorld> localFrame (world : 'w) = - Env.setLocalFrame localFrame (world.GetEnv ()) - - let tryImport<'w when 'w :> 'w ScriptingWorld> ty value (world : 'w) = - tryImport world.TryImport ty value - - let tryExport<'w when 'w :> 'w ScriptingWorld> ty value (world : 'w) = - tryExport world.TryExport ty value - - let log expr = - match expr with - | Violation (names, error, originOpt) -> - Log.info ^ - "Unexpected Violation: " + String.concat Constants.Scripting.ViolationSeparatorStr names + "\n" + - "Due to: " + error + "\n" + - SymbolOrigin.tryPrint originOpt + "\n" - | _ -> () - - let rec getIntrinsics<'w when 'w :> 'w ScriptingWorld> () = - if isNull Intrinsics then - let intrinsics = - [("=", evalBinary EqFns) - ("<>", evalBinary NotEqFns) - ("<", evalBinary LtFns) - (">", evalBinary GtFns) - ("<=", evalBinary LtEqFns) - (">=", evalBinary GtEqFns) - ("+", evalBinary AddFns) - ("-", evalBinary SubFns) - ("*", evalBinary MulFns) - ("/", evalBinary DivFns) - ("%", evalBinary ModFns) - ("!", evalSinglet evalDereference) - ("not", evalBoolUnary not) - ("hash", evalUnary HashFns) - ("toEmpty", evalUnary ToEmptyFns) - ("toIdentity", evalUnary ToIdentityFns) - ("toMin", evalUnary ToMinFns) - ("toMax", evalUnary ToMaxFns) - ("inc", evalUnary IncFns) - ("dec", evalUnary DecFns) - ("negate", evalUnary NegateFns) - ("pow", evalBinary PowFns) - ("root", evalBinary RootFns) - ("sqr", evalUnary SqrFns) - ("sqrt", evalUnary SqrtFns) - ("floor", evalUnary FloorFns) - ("ceiling", evalUnary CeilingFns) - ("truncate", evalUnary TruncateFns) - ("round", evalUnary RoundFns) - ("exp", evalUnary ExpFns) - ("log", evalUnary LogFns) - ("sin", evalUnary SinFns) - ("cos", evalUnary CosFns) - ("tan", evalUnary TanFns) - ("asin", evalUnary AsinFns) - ("acos", evalUnary AcosFns) - ("atan", evalUnary AtanFns) - ("length", evalUnary LengthFns) - ("normal", evalUnary NormalFns) - ("cross", evalBinary CrossFns) - ("dot", evalBinary DotFns) - ("bool", evalUnary BoolFns) - ("int", evalUnary IntFns) - ("int64", evalUnary Int64Fns) - ("single", evalUnary SingleFns) - ("double", evalUnary DoubleFns) - ("string", evalUnary StringFns) - ("getTypeName", evalSinglet evalGetTypeName) - ("tryIndex", evalDoublet evalTryIndex) - ("hasIndex", evalDoublet evalHasIndex) - ("index", evalDoublet evalIndex) - ("getName", evalSinglet evalGetName) - ("tuple", evalTuple) - ("pair", evalTuple) - ("fst", evalSinglet (evalIndexInt 0)) - ("snd", evalSinglet (evalIndexInt 1)) - ("thd", evalSinglet (evalIndexInt 2)) - ("fth", evalSinglet (evalIndexInt 3)) - ("fif", evalSinglet (evalIndexInt 4)) - ("nth", evalDoublet evalNth) - ("some", evalSinglet evalSome) - ("isNone", evalSinglet evalIsNone) - ("isSome", evalSinglet evalIsSome) - ("isEmpty", evalSinglet (evalIsEmpty evalApply)) - ("notEmpty", evalSinglet (evalNotEmpty evalApply)) - ("tryUncons", evalSinglet (evalTryUncons evalApply)) - ("uncons", evalSinglet (evalUncons evalApply)) - ("cons", evalDoublet evalCons) - ("commit", evalSinglet evalCommit) - ("tryHead", evalSinglet (evalTryHead evalApply)) - ("head", evalSinglet (evalHead evalApply)) - ("tryTail", evalSinglet (evalTryTail evalApply)) - ("tail", evalSinglet (evalTail evalApply)) - ("scanWhile", evalTriplet (evalScanWhile evalApply)) - ("scani", evalTriplet (evalScani evalApply)) - ("scan", evalTriplet (evalScan evalApply)) - ("foldWhile", evalTriplet (evalFoldWhile evalApply)) - ("foldi", evalTriplet (evalFoldi evalApply)) - ("fold", evalTriplet (evalFold evalApply)) - ("mapi", evalDoublet (evalMapi evalApply)) - ("map", evalDoublet (evalMap evalApply)) - ("contains", evalDoublet (evalContains evalApply)) - ("toString", evalSinglet evalToString) - ("codata", evalDoublet evalCodata) - ("toCodata", evalSinglet evalToCodata) - ("list", evalList) - ("toList", evalSinglet (evalToList evalApply)) - ("ring", evalRing) - ("toRing", evalSinglet (evalToRing evalApply)) - ("add", evalDoublet evalCons) - ("remove", evalDoublet evalRemove) - ("toTable", evalSinglet evalToTable)] |> - dictPlus - Intrinsics <- intrinsics - intrinsics - else Intrinsics :?> Dictionary Expr array -> SymbolOrigin option -> 'w -> struct (Expr * 'w)> - - and internal evalIntrinsicInner<'w when 'w :> 'w ScriptingWorld> fnName argsEvaled originOpt (world : 'w) = - let intrinsics = getIntrinsics () - match intrinsics.TryGetValue fnName with - | (true, intrinsic) -> intrinsic fnName argsEvaled originOpt world - | (false, _) -> struct (Violation (["InvalidFunctionTargetBinding"], "Cannot apply the non-existent binding '" + fnName + "'.", originOpt), world) - - and evalOverload fnName argsEvaled originOpt world = - if Array.notEmpty argsEvaled then - match Array.last argsEvaled with - | Pluggable pluggable -> - let pluggableTypeName = pluggable.TypeName - let xfnName = fnName + "_" + pluggableTypeName - let xfnBinding = Binding (xfnName, ref UncachedBinding, ref UnknownBindingType, None) - let evaleds = Array.cons xfnBinding argsEvaled - evalApply evaleds originOpt world - | Union (name, _) - | Record (name, _, _) -> - let xfnName = fnName + "_" + name - let xfnBinding = Binding (xfnName, ref UncachedBinding, ref UnknownBindingType, None) - let evaleds = Array.cons xfnBinding argsEvaled - evalApply evaleds originOpt world - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["InvalidOverload"], "Could not find overload for '" + fnName + "' for target.", originOpt), world) - else struct (Violation (["InvalidFunctionTargetBinding"], "Cannot apply the non-existent binding '" + fnName + "'.", originOpt), world) - - and evalUnionUnevaled name exprs world = - let struct (evaleds, world) = evalMany exprs world - struct (Union (name, evaleds), world) - - and evalTableUnevaled exprPairs world = - let struct (evaledPairs, world) = - List.fold (fun struct (evaledPairs, world) (exprKey, exprValue) -> - let struct (evaledKey, world) = eval exprKey world - let struct (evaledValue, world) = eval exprValue world - struct ((evaledKey, evaledValue) :: evaledPairs, world)) - struct ([], world) - exprPairs - let evaledPairs = List.rev evaledPairs - struct (Table (Map.ofList evaledPairs), world) - - and evalRecordUnevaled name exprPairs world = - let struct (evaledPairs, world) = - List.fold (fun struct (evaledPairs, world) (fieldName, expr) -> - let struct (evaledValue, world) = eval expr world - struct ((fieldName, evaledValue) :: evaledPairs, world)) - struct ([], world) - exprPairs - let evaledPairs = List.rev evaledPairs - let map = evaledPairs |> List.mapi (fun i (fieldName, _) -> (fieldName, i)) |> Map.ofList - let fields = evaledPairs |> List.map snd |> Array.ofList - struct (Record (name, map, fields), world) - - and evalBinding<'w when 'w :> 'w ScriptingWorld> expr name cachedBinding bindingType originOpt (world : 'w) = - match tryGetBinding name cachedBinding bindingType world with - | None -> - match !bindingType with - | UnknownBindingType -> - if (getIntrinsics<'w> ()).ContainsKey name then bindingType := Intrinsic; struct (expr, world) - elif FOption.isSome (world.TryGetExtrinsic name) then bindingType := Extrinsic; struct (expr, world) - else bindingType := Environmental; struct (expr, world) - | Intrinsic -> struct (expr, world) - | Extrinsic -> struct (expr, world) - | Environmental -> struct (Violation (["NonexistentBinding"], "Non-existent binding '" + name + "'.", originOpt), world) - | Some binding -> struct (binding, world) - - and evalUpdateIntInner fnName index target value originOpt world = - match target with - | String str -> - if index >= 0 && index < String.length str then - match value with - | String str2 when str2.Length = 1 -> - let left = str.Substring (0, index) - let right = str.Substring (index, str.Length) - Right struct (String (left + str2 + right), world) - | _ -> Left struct (Violation (["InvalidArgumentValue"; String.capitalize fnName], "String update value must be a String of length 1.", originOpt), world) - else Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "String does not contain element at index " + string index + ".", originOpt), world) - | Option opt -> - match (index, opt) with - | (0, Some value) -> Right struct (value, world) - | (_, _) -> Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Could not update at index " + string index + ".", originOpt), world) - | List _ -> Left struct (Violation (["NotImplemented"; String.capitalize fnName], "Updating lists by index is not yet implemented.", originOpt), world) // TODO: implement - | Table map -> Right struct (Table (Map.add (Int index) value map), world) - | Tuple elements - | Union (_, elements) - | Record (_, _, elements) -> - if index < elements.Length then - let elements' = Array.copy elements - elements'.[index] <- value - match target with - | Tuple _ -> Right struct (Tuple elements', world) - | Union (name, _) -> Right struct (Union (name, elements'), world) - | Record (name, map, _) -> Right struct (Record (name, map, elements'), world) - | _ -> failwithumf () - else Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Could not update structure at index " + string index + ".", originOpt), world) - | _ -> - match evalOverload fnName [|Int index; value; target|] originOpt world with - | struct (Violation _, _) as error -> Left error - | struct (_, _) as success -> Right success - - and evalUpdateKeywordInner fnName keyword target value originOpt world = - match target with - | Table map -> - Right struct (Table (Map.add (Keyword keyword) value map), world) - | Record (name, map, fields) -> - match Map.tryFind keyword map with - | Some index -> - if index < fields.Length then - let fields' = Array.copy fields - fields'.[index] <- value - Right struct (Record (name, map, fields'), world) - else Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Record does not contain element with name '" + name + "'.", originOpt), world) - | None -> - Left struct (Violation (["OutOfRangeArgument"; String.capitalize fnName], "Record does not contain element with name '" + name + "'.", originOpt), world) - | Violation _ as violation -> - Left struct (violation, world) - | _ -> - match evalOverload fnName [|Keyword keyword; value; target|] originOpt world with - | struct (Violation _, _) as error -> Left error - | struct (_, _) as success -> Right success - - and evalUpdateInner fnName indexerExpr targetExpr valueExpr originOpt world = - let struct (indexer, world) = eval indexerExpr world - let struct (target, world) = eval targetExpr world - let struct (value, world) = eval valueExpr world - match indexer with - | Violation _ as v -> Left struct (v, world) - | Int index -> evalUpdateIntInner fnName index target value originOpt world - | Keyword keyword -> evalUpdateKeywordInner fnName keyword target value originOpt world - | _ -> - match target with - | Table map -> Right struct (Table (Map.add indexer valueExpr map), world) - | _ -> - match evalOverload fnName [|indexer; value; target|] originOpt world with - | struct (Violation _, _) as error -> Left error - | struct (_, _) as success -> Right success - - and evalTryUpdate indexerExpr targetExpr valueExpr originOpt world = - match evalUpdateInner "tryUpdate" indexerExpr targetExpr valueExpr originOpt world with - | Right struct (evaled, world) -> struct (Option (Some evaled), world) - | Left struct (_, world) -> struct (Option None, world) - - and evalUpdate indexerExpr targetExpr valueExpr originOpt world = - match evalUpdateInner "update" indexerExpr targetExpr valueExpr originOpt world with - | Right success -> success - | Left error -> error - - // TODO: decompose this function - it's too hard to read - and evalApply<'w when 'w :> 'w ScriptingWorld> (exprs : Expr array) (originOpt : SymbolOrigin option) (world : 'w) : struct (Expr * 'w) = - if Array.notEmpty exprs then - let (exprsHead, exprsTail) = (Array.head exprs, Array.tail exprs) - let struct (headEvaled, world) = eval exprsHead world in annotateWorld world // force the type checker to see the world as it is - match headEvaled with - | Keyword keyword -> - let struct (tailEvaled, world) = evalMany exprsTail world - let union = Union (keyword, tailEvaled) - struct (union, world) - | Binding (fnName, _, bindingType, originOpt) -> - // NOTE: when evaluation leads here, we infer that we have either an extrinsic or intrinsic function, - // otherwise it would have led to the Fun case... Also, binding type should be decided by this point. - match bindingType.Value with - | UnknownBindingType -> - failwithumf () - | Intrinsic -> - let struct (argsEvaled, world) = evalMany exprsTail world - match evalIntrinsicInner fnName argsEvaled originOpt world with - | struct (Violation _, world) -> evalOverload fnName argsEvaled originOpt world - | success -> success - | Extrinsic -> - let args = Array.tail exprs - let extrinsicOpt = world.TryGetExtrinsic fnName - if FOption.isSome extrinsicOpt - then extrinsicOpt.Value fnName args originOpt world - else failwithumf () - | Environmental -> - failwithumf () - | Fun (pars, parsCount, body, _, framesOpt, originOpt) -> - let struct (tailEvaled, world) = evalMany exprsTail world - let struct (framesCurrentOpt, world) = - match framesOpt with - | Some frames -> - let framesCurrent = getProceduralFrames world - setProceduralFrames (frames :?> ProceduralFrame list) world - struct (Some framesCurrent, world) - | None -> struct (None, world) - let struct (evaled, world) = - if tailEvaled.Length = parsCount then - let bindings = Array.map2 (fun par evaledArg -> struct (par, evaledArg)) pars tailEvaled - addProceduralBindings (AddToNewFrame parsCount) bindings world - let struct (evaled, world) = eval body world - removeProceduralBindings world - struct (evaled, world) - else struct (Violation (["MalformedLambdaInvocation"], "Wrong number of arguments.", originOpt), world) - match framesCurrentOpt with - | Some framesCurrent -> - setProceduralFrames framesCurrent world - struct (evaled, world) - | None -> struct (evaled, world) - | Violation _ as error -> struct (error, world) - | _ -> struct (Violation (["MalformedApplication"], "Cannot apply the non-binding '" + scstring headEvaled + "'.", originOpt), world) - else struct (Unit, world) - - and evalApplyAnd exprs originOpt world = - match exprs with - | [|left; right|] -> - match eval left world with - | struct (Bool false, _) as never -> never - | struct (Bool true, world) -> - match eval right world with - | struct (Bool _, _) as result -> result - | struct (Violation _, _) as error -> error - | _ -> struct (Violation (["InvalidArgumentType"; "&&"], "Cannot apply a logic function to non-Bool values.", originOpt), world) - | struct (Violation _, _) as error -> error - | _ -> struct (Violation (["InvalidArgumentType"; "&&"], "Cannot apply a logic function to non-Bool values.", originOpt), world) - | _ -> struct (Violation (["InvalidArgumentCount"; "&&"], "Incorrect number of arguments for application of '&&'; 2 arguments required.", originOpt), world) - - and evalApplyOr exprs originOpt world = - match exprs with - | [|left; right|] -> - match eval left world with - | struct (Bool true, _) as always -> always - | struct (Bool false, world) -> - match eval right world with - | struct (Bool _, _) as result -> result - | struct (Violation _, _) as error -> error - | _ -> struct (Violation (["InvalidArgumentType"; "&&"], "Cannot apply a logic function to non-Bool values.", originOpt), world) - | struct (Violation _, _) as error -> error - | _ -> struct (Violation (["InvalidArgumentType"; "&&"], "Cannot apply a logic function to non-Bool values.", originOpt), world) - | _ -> struct (Violation (["InvalidArgumentCount"; "&&"], "Incorrect number of arguments for application of '&&'; 2 arguments required.", originOpt), world) - - and evalLet4 binding body originOpt world = - let world = - match binding with - | VariableBinding (name, body) -> - let struct (evaled, world) = eval body world - addProceduralBinding (AddToNewFrame 1) name evaled world - world - | FunctionBinding (name, args, body) -> - let frames = getProceduralFrames world :> obj - let fn = Fun (args, args.Length, body, true, Some frames, originOpt) - addProceduralBinding (AddToNewFrame 1) name fn world - world - let struct (evaled, world) = eval body world - removeProceduralBindings world - struct (evaled, world) - - and evalLetMany4 bindingsHead bindingsTail bindingsCount body originOpt world = - let world = - match bindingsHead with - | VariableBinding (name, body) -> - let struct (bodyValue, world) = eval body world - addProceduralBinding (AddToNewFrame bindingsCount) name bodyValue world - world - | FunctionBinding (name, args, body) -> - let frames = getProceduralFrames world :> obj - let fn = Fun (args, args.Length, body, true, Some frames, originOpt) - addProceduralBinding (AddToNewFrame bindingsCount) name fn world - world - let world = - List.foldi (fun i world binding -> - match binding with - | VariableBinding (name, body) -> - let struct (bodyValue, world) = eval body world - addProceduralBinding (AddToHeadFrame ^ inc i) name bodyValue world - world - | FunctionBinding (name, args, body) -> - let frames = getProceduralFrames world :> obj - let fn = Fun (args, args.Length, body, true, Some frames, originOpt) - addProceduralBinding (AddToHeadFrame ^ inc i) name fn world - world) - world - bindingsTail - let struct (evaled, world) = eval body world - removeProceduralBindings world - struct (evaled, world) - - and evalLet binding body originOpt world = - evalLet4 binding body originOpt world - - and evalLetMany bindings body originOpt world = - match bindings with - | bindingsHead :: bindingsTail -> - let bindingsCount = List.length bindingsTail + 1 - evalLetMany4 bindingsHead bindingsTail bindingsCount body originOpt world - | [] -> struct (Violation (["MalformedLetOperation"], "Let operation must have at least 1 binding.", originOpt), world) - - and evalFun fn pars parsCount body framesPushed framesOpt originOpt world = - if not framesPushed then - if Option.isNone framesOpt then - let frames = getProceduralFrames world :> obj - struct (Fun (pars, parsCount, body, true, Some frames, originOpt), world) - else struct (Fun (pars, parsCount, body, true, framesOpt, originOpt), world) - else struct (fn, world) - - and evalIf condition consequent alternative originOpt world = - match eval condition world with - | struct (Bool bool, world) -> if bool then eval consequent world else eval alternative world - | struct (Violation _ as evaled, world) -> struct (evaled, world) - | struct (_, world) -> struct (Violation (["InvalidIfCondition"], "Must provide an expression that evaluates to a Bool in an if condition.", originOpt), world) - - and evalMatch input (cases : (Expr * Expr) array) originOpt world = - let struct (input, world) = eval input world - let resultEir = - Seq.foldUntilRight (fun world (condition, consequent) -> - let struct (evaledInput, world) = eval condition world - match evalBinaryInner EqFns "=" input evaledInput originOpt world with - | struct (Bool true, world) -> Right (eval consequent world) - | struct (Bool false, world) -> Left world - | struct (Violation _, world) -> Right struct (evaledInput, world) - | _ -> failwithumf ()) - (Left world) - cases - match resultEir with - | Right success -> success - | Left world -> struct (Violation (["InexhaustiveMatch"], "A match expression failed to satisfy any of its cases.", originOpt), world) - - and evalSelect exprPairs originOpt world = - let resultEir = - Seq.foldUntilRight (fun world (condition, consequent) -> - match eval condition world with - | struct (Bool bool, world) -> if bool then Right (eval consequent world) else Left world - | struct (Violation _ as evaled, world) -> Right struct (evaled, world) - | struct (_, world) -> Right struct (Violation (["InvalidSelectCondition"], "Must provide an expression that evaluates to a Bool in a case condition.", originOpt), world)) - (Left world) - exprPairs - match resultEir with - | Right success -> success - | Left world -> struct (Violation (["InexhaustiveSelect"], "A select expression failed to satisfy any of its cases.", originOpt), world) - - and evalTry body handlers _ world = - match eval body world with - | struct (Violation (categories, _, _) as evaled, world) -> - match - List.foldUntilRight (fun world (handlerCategories, handlerBody) -> - let categoriesTrunc = List.truncate (List.length handlerCategories) categories - if categoriesTrunc = handlerCategories then Right (eval handlerBody world) else Left world) - (Left world) - handlers with - | Right success -> success - | Left world -> struct (evaled, world) - | success -> success - - and evalDo exprs _ world = - let evaledEir = - List.foldWhileRight (fun struct (_, world) expr -> - match eval expr world with - | struct (Violation _, _) as error -> Left error - | success -> Right success) - (Right struct (Unit, world)) - exprs - Either.amb evaledEir - - and evalDefine binding originOpt world = - let struct (bound, world) = - match binding with - | VariableBinding (name, body) -> - let struct (evaled, world) = eval body world - struct (tryAddDeclarationBinding name evaled world, world) - | FunctionBinding (name, args, body) -> - let frames = getProceduralFrames world :> obj - let fn = Fun (args, args.Length, body, true, Some frames, originOpt) - struct (tryAddDeclarationBinding name fn world, world) - if bound - then struct (Unit, world) - else struct (Violation (["InvalidDeclaration"], "Can make declarations only at the top-level.", None), world) - - /// Evaluate an expression. - and eval expr world = - match expr with - | Violation _ - | Unit _ - | Bool _ - | Int _ - | Int64 _ - | Single _ - | Double _ - | String _ - | Keyword _ - | Tuple _ - | Union _ - | Pluggable _ - | Option _ - | Codata _ - | List _ - | Ring _ - | Table _ - | Record _ -> struct (expr, world) - | UnionUnevaled (name, exprs) -> evalUnionUnevaled name exprs world - | TableUnevaled exprPairs -> evalTableUnevaled exprPairs world - | RecordUnevaled (name, exprPairs) -> evalRecordUnevaled name exprPairs world - | Binding (name, cachedBinding, bindingType, originOpt) as expr -> evalBinding expr name cachedBinding bindingType originOpt world - | TryUpdate (expr, expr2, expr3, _, originOpt) -> evalTryUpdate expr expr2 expr3 originOpt world - | Update (expr, expr2, expr3, _, originOpt) -> evalUpdate expr expr2 expr3 originOpt world - | Apply (exprs, _, originOpt) -> evalApply exprs originOpt world - | ApplyAnd (exprs, _, originOpt) -> evalApplyAnd exprs originOpt world - | ApplyOr (exprs, _, originOpt) -> evalApplyOr exprs originOpt world - | Let (binding, body, originOpt) -> evalLet binding body originOpt world - | LetMany (bindings, body, originOpt) -> evalLetMany bindings body originOpt world - | Fun (pars, parsCount, body, framesPushed, framesOpt, originOpt) as fn -> evalFun fn pars parsCount body framesPushed framesOpt originOpt world - | If (condition, consequent, alternative, originOpt) -> evalIf condition consequent alternative originOpt world - | Match (input, cases, originOpt) -> evalMatch input cases originOpt world - | Select (exprPairs, originOpt) -> evalSelect exprPairs originOpt world - | Try (body, handlers, originOpt) -> evalTry body handlers originOpt world - | Do (exprs, originOpt) -> evalDo exprs originOpt world - | Quote _ as quote -> struct (quote, world) - | Define (binding, originOpt) -> evalDefine binding originOpt world - - /// Evaluate a sequence of expressions. - and evalMany (exprs : Expr array) world = - let evaleds = Array.zeroCreate exprs.Length - let world = - Seq.foldi - (fun i world expr -> - let struct (evaled, world) = eval expr world - evaleds.[i] <- evaled - world) - world - exprs - struct (evaleds, world) - - /// Evaluate an expression, with logging on violation result. - let evalWithLogging expr world = - let struct (evaled, world) = eval expr world - log evaled - struct (evaled, world) - - /// Evaluate a series of expressions, with logging on violation result. - let evalManyWithLogging exprs world = - let struct (evaleds, world) = evalMany exprs world - Array.iter log evaleds - struct (evaleds, world) - - /// Attempt to evaluate a script. - let tryEvalScript choose scriptFilePath world = - Log.info ("Evaluating script '" + scriptFilePath + "...") - try let scriptStr = - scriptFilePath |> - File.ReadAllText |> - String.unescape - let script = - scriptStr |> - (fun str -> Symbol.OpenSymbolsStr + str + Symbol.CloseSymbolsStr) |> - scvalue - let struct (evaleds, world) = evalMany script world - Log.info ("Successfully evaluated script '" + scriptFilePath + ".") - Right struct (scriptStr, evaleds, world) - with exn -> - let error = "Failed to evaluate script '" + scriptFilePath + "' due to: " + scstring exn - Log.info error - Left struct (error, choose world) \ No newline at end of file diff --git a/Prime/Prime/Seq.fs b/Prime/Prime/Seq.fs deleted file mode 100644 index 5fa4944468..0000000000 --- a/Prime/Prime/Seq.fs +++ /dev/null @@ -1,141 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open Prime - -[] -module Seq = - - /// Check that a sequence is not empty. - let rec notEmpty seq = - not (Seq.isEmpty seq) - - /// Get Some head of the seq or None. - let inline tryHead seq = - Seq.tryFind tautology seq - - /// Get a seq head or a default value if there is none. - let inline headOrDefault seq aDefault = - match tryHead seq with - | Some _ as head -> head - | None -> aDefault - - /// Convert option values to definite values. - let inline definitize opts = - Seq.choose id opts - - /// Convert option values to definite values, returning an additional flag to indicate that all values were some. - let definitizePlus opts = - let struct (flag, list) = - Seq.foldBack - (fun opt struct (allDefinite, values) -> - match opt with - | Some value -> struct (allDefinite, value :: values) - | None -> struct (false, values)) - opts struct (true, []) - (flag, Seq.ofList list) - - /// Fold with two inputs (plus state). - let fold2 folder state seq seq2 = - let zipped = Seq.zip seq seq2 - Seq.fold (fun state (a, b) -> folder state a b) state zipped - - /// Fold, now with a counter! - let foldi folder state seq = - let struct (_, result) = - Seq.fold - (fun struct (i, state) item -> struct (i + 1, folder i state item)) - struct (0, state) - seq - result - - /// Fold-back for seqs. - let foldBack folder values state = - List.foldBack folder (List.ofSeq values) state - - /// Check if no items satisfy a predicate in a seq. - let fornone pred seq = - let notPred = not << pred - Seq.forall notPred seq - - /// A more tolerant and open-minded take. - let tryTake (count : int) (seq : _ seq) = - System.Linq.Enumerable.Take (seq, count) - - /// A more tolerant and open-minded skip. - let trySkip (count : int) (seq : _ seq) = - System.Linq.Enumerable.Skip (seq, count) - - /// Project the first sequence onto the second. - let project projector (seq_ : 'a seq) (seq2 : 'b option seq) = - use enr = seq_.GetEnumerator () - use enr2 = seq2.GetEnumerator () - seq { - while enr.MoveNext () do - let projection = - if enr2.MoveNext () then - match projector enr2.Current with - | Some projection -> projection - | None -> enr.Current - else enr.Current - yield projection } - - /// Implement a fold while folder results in Some. - let foldWhile folder (state : 's) (seq : 't seq) = - let mutable lastState = state - let mutable stateOpt = Some lastState - use mutable enr = seq.GetEnumerator () - while stateOpt.IsSome && enr.MoveNext () do - lastState <- stateOpt.Value - stateOpt <- folder lastState enr.Current - match stateOpt with - | Some state -> state - | None -> lastState - - /// Implement a fold while folder results in Right. - let foldWhileRight folder (state : Either<_, _>) (seq : 't seq) = - let mutable state = state // make mutable - use mutable enr = seq.GetEnumerator () - while Either.isRight state && enr.MoveNext () do - state <- folder (Either.getRightValue state) enr.Current - state - - /// Implement a fold until folder results in Some. - let foldUntil folder (state : 's) (seq : 't seq) = - let mutable isFirst = true // no do while necessitates this flag - let mutable lastState = state - let mutable stateOpt = Some lastState - use mutable enr = seq.GetEnumerator () - while (isFirst || stateOpt.IsNone) && enr.MoveNext () do - isFirst <- false - lastState <- stateOpt.Value - stateOpt <- folder lastState enr.Current - match stateOpt with - | Some state -> state - | None -> lastState - - /// Implement a fold until folder results in Right. - let foldUntilRight folder (state : Either<_, _>) (seq : 't seq) = - let mutable state = state // make mutable - use mutable enr = seq.GetEnumerator () - while Either.isLeft state && enr.MoveNext () do - state <- folder (Either.getLeftValue state) enr.Current - state - - /// Check that a predicate passes for NO items in a sequence. - let rec notExists pred seq = - not (Seq.exists pred seq) - - /// Split a sequence on a predicate. - let split pred seq = - let rec splitInner pred left right seq = - match tryHead seq with - | Some head -> - if pred head - then splitInner pred (head :: left) right (Seq.tail seq) - else splitInner pred left (head :: right) (Seq.tail seq) - | None -> struct (left, right) - let struct (list, list2) = splitInner pred [] [] seq - (List.rev list, List.rev list2) \ No newline at end of file diff --git a/Prime/Prime/Set.fs b/Prime/Prime/Set.fs deleted file mode 100644 index 0778bb81d3..0000000000 --- a/Prime/Prime/Set.fs +++ /dev/null @@ -1,27 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open Prime - -/// Alternative type of set when its name is reified. -type FSharpSet<'a when 'a : comparison> = Set<'a> - -[] -module Set = - - /// Check that a set is not empty. - let rec notEmpty set = - not (Set.isEmpty set) - - /// Make a singleton set. - let singleton value = - Set.add value Set.empty - - /// Add multiple values to a set. - let addMany values set = - Seq.fold - (fun set value -> Set.add value set) - set - values \ No newline at end of file diff --git a/Prime/Prime/SetTests.fs b/Prime/Prime/SetTests.fs deleted file mode 100644 index 1144087601..0000000000 --- a/Prime/Prime/SetTests.fs +++ /dev/null @@ -1,70 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime.Tests -open FsCheck.Xunit -open Prime -open System.Diagnostics -module SetTests = - - type SetAction<'a when 'a : comparison> = - | Add of 'a - | Remove of 'a - | FoldAddingCombination of 'a - - /// Keeps a reference to all persistent collections returned after - /// performing actions, and after they are all applied, checks - /// that they equal what we would get from FSharp.Core.Set - let eqSetsAfterSteps - (fsset : Set<'a>) - (testSet : 's) - (actions : SetAction<'a> array) - (add : 'a->'s->'s) - (remove : 'a->'s->'s) - (fold : ('s->'a->'s)->'s->'s->'s) - (combine : 'a->'a->'a) - (eq : 's->Set<'a>->bool) = - - let applyAction fsset testSet action = - match action with - | SetAction.Add k -> - (Set.add k fsset, add k testSet) - | SetAction.FoldAddingCombination arg -> - let newFsset = Set.fold (fun acc e -> Set.add (combine arg e) acc) fsset fsset - let newTestSet = fold (fun acc e -> add (combine arg e) acc) testSet testSet - (newFsset, newTestSet) - | SetAction.Remove k -> - (Set.remove k fsset, remove k testSet) - - let (fssets, testMaps) = - Array.fold - (fun acc action -> - match acc with - | (fsmap :: fsmaps, testMap :: testMaps) -> - let (newF, newT) = applyAction fsmap testMap action - (newF :: fsmap :: fsmaps, newT :: testMap :: testMaps) - | _ -> failwithumf ()) - ([fsset], [testSet]) - actions - - let success = List.forall2 eq testMaps fssets - if not success then - Trace.WriteLine "FAILURE:" - List.iteri2 (fun i fsset testSet -> - if i > 0 then Trace.WriteLine (sprintf "After action %A" actions.[i-1]) - Trace.WriteLine (sprintf "fsset: %A\ntestSet: %A" fsset testSet)) - (List.rev fssets) - (List.rev testMaps) - success - - [] - let hsetsEqSetsAfterSteps (initialSet : Set) (actions : SetAction[]) = - let testSet = HSet.ofSeq initialSet - let eq (hset : HSet<_>) (fsset : Set<_>) = Set.ofSeq hset = fsset - eqSetsAfterSteps initialSet testSet actions HSet.add HSet.remove HSet.fold (+) eq - - [] - let usetsEqSetsAfterSteps (initialSet : Set) (actions : SetAction[]) = - let testSet = USet.makeFromSeq Functional initialSet - let eq (uset : USet<_>) (fsset : Set<_>) = Set.ofSeq uset = fsset - eqSetsAfterSteps initialSet testSet actions USet.add USet.remove USet.fold (+) eq diff --git a/Prime/Prime/Stream.fs b/Prime/Prime/Stream.fs deleted file mode 100644 index 3ac108c9a1..0000000000 --- a/Prime/Prime/Stream.fs +++ /dev/null @@ -1,522 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Diagnostics -open Prime - -/// A stream in the functional reactive style. -type [] Stream<'a, 'g, 'w when 'g :> Participant and 'w :> EventWorld<'g, 'w>> = - { Subscribe : 'w -> 'a Address * ('w -> 'w) * 'w } - -// TODO: document track functions. -module Stream = - - (* Event-Based Combinators *) - - /// Make a stream of an event at the given address. - let [] stream<'a, 'g, 'w when 'g :> Participant and 'w :> EventWorld<'g, 'w>> - (eventAddress : 'a Address) : Stream<'a, 'g, 'w> = - let subscribe = fun (world : 'w) -> - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let subscriptionKey = makeGuid () - let subscriptionAddress = ntoa<'a> (scstring subscriptionKey) - let unsubscribe = fun world -> EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let subscription = fun evt world -> - let eventTrace = EventTrace.record "Stream" "stream" evt.Trace - let world = EventWorld.publishPlus<'a, 'g, 'g, 'w> EventWorld.sortSubscriptionsNone evt.Data subscriptionAddress eventTrace globalParticipant false world - (Cascade, world) - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription eventAddress globalParticipant world |> snd - (subscriptionAddress, unsubscribe, world) - { Subscribe = subscribe } - - let [] trackEvent4 - (tracker : 'c -> Event<'a, 'g> -> 'w -> 'c * bool) - (transformer : 'c -> 'b) - (state : 'c) - (stream : Stream<'a, 'g, 'w>) : - Stream<'b, 'g, 'w> = - let subscribe = fun (world : 'w) -> - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let stateKey = makeGuid () - let world = EventWorld.addEventState stateKey state world - let subscriptionKey = makeGuid () - let subscriptionAddress = ntoa<'b> (scstring subscriptionKey) - let (eventAddress, unsubscribe, world) = stream.Subscribe world - let unsubscribe = fun world -> - let world = EventWorld.removeEventState stateKey world - let world = unsubscribe world - EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let subscription = fun evt world -> - let state = EventWorld.getEventState stateKey world - let (state, tracked) = tracker state evt world - let world = EventWorld.addEventState stateKey state world - let world = - if tracked then - let eventTrace = EventTrace.record "Stream" "trackEvent4" evt.Trace - let eventData = transformer state - EventWorld.publishPlus<'b, 'g, 'g, 'w> EventWorld.sortSubscriptionsNone eventData subscriptionAddress eventTrace globalParticipant false world - else world - (Cascade, world) - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription eventAddress globalParticipant world |> snd - (subscriptionAddress, unsubscribe, world) - { Subscribe = subscribe } - - let [] trackEvent2 - (tracker : 'a -> Event<'a, 'g> -> 'w -> 'a * bool) - (stream : Stream<'a, 'g, 'w>) : - Stream<'a, 'g, 'w> = - let subscribe = fun (world : 'w) -> - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let stateKey = makeGuid () - let world = EventWorld.addEventState stateKey None world - let subscriptionKey = makeGuid () - let subscriptionAddress = ntoa<'a> (scstring subscriptionKey) - let (eventAddress, unsubscribe, world) = stream.Subscribe world - let unsubscribe = fun world -> - let world = EventWorld.removeEventState stateKey world - let world = unsubscribe world - EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let subscription = fun evt world -> - let stateOpt = EventWorld.getEventState stateKey world - let state = match stateOpt with Some state -> state | None -> evt.Data - let (state, tracked) = tracker state evt world - let world = EventWorld.addEventState stateKey state world - let world = - if tracked then - let eventTrace = EventTrace.record "Stream" "trackEvent2" evt.Trace - EventWorld.publishPlus<'a, 'g, 'g, 'w> EventWorld.sortSubscriptionsNone state subscriptionAddress eventTrace globalParticipant false world - else world - (Cascade, world) - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription eventAddress globalParticipant world |> snd - (subscriptionAddress, unsubscribe, world) - { Subscribe = subscribe } - - let [] trackEvent - (tracker : 'b -> 'w -> 'b * bool) (state : 'b) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - let subscribe = fun (world : 'w) -> - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let stateKey = makeGuid () - let world = EventWorld.addEventState stateKey state world - let subscriptionKey = makeGuid () - let subscriptionAddress = ntoa<'a> (scstring subscriptionKey) - let (eventAddress, unsubscribe, world) = stream.Subscribe world - let unsubscribe = fun world -> - let world = EventWorld.removeEventState stateKey world - let world = unsubscribe world - EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let subscription = fun evt world -> - let state = EventWorld.getEventState stateKey world - let (state, tracked) = tracker state world - let world = EventWorld.addEventState stateKey state world - let world = - if tracked then - let eventTrace = EventTrace.record "Stream" "trackEvent" evt.Trace - EventWorld.publishPlus<'a, 'g, 'g, 'w> EventWorld.sortSubscriptionsNone evt.Data subscriptionAddress eventTrace globalParticipant false world - else world - (Cascade, world) - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription eventAddress globalParticipant world |> snd - (subscriptionAddress, unsubscribe, world) - { Subscribe = subscribe } - - /// Fold over a stream, then map the result. - let [] foldMapEvent (f : 'b -> Event<'a, 'g> -> 'w -> 'b) g s (stream : Stream<'a, 'g, 'w>) : Stream<'c, 'g, 'w> = - trackEvent4 (fun b a w -> (f b a w, true)) g s stream - - /// Fold over a stream, aggegating the result. - let [] foldEvent (f : 'b -> Event<'a, 'g> -> 'w -> 'b) s (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - trackEvent4 (fun b a w -> (f b a w, true)) id s stream - - /// Reduce over a stream, accumulating the result. - let [] reduceEvent (f : 'a -> Event<'a, 'g> -> 'w -> 'a) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - trackEvent2 (fun a a2 w -> (f a a2 w, true)) stream - - /// Filter a stream by the given 'pred' procedure. - let [] filterEvent - (pred : Event<'a, 'g> -> 'w -> bool) (stream : Stream<'a, 'g, 'w>) = - let subscribe = fun (world : 'w) -> - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let subscriptionKey = makeGuid () - let subscriptionAddress = ntoa<'a> (scstring subscriptionKey) - let (eventAddress, unsubscribe, world) = stream.Subscribe world - let unsubscribe = fun world -> - let world = unsubscribe world - EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let subscription = fun evt world -> - let world = - if pred evt world then - let eventTrace = EventTrace.record "Stream" "filterEvent" evt.Trace - EventWorld.publishPlus<'a, 'g, 'g, 'w> EventWorld.sortSubscriptionsNone evt.Data subscriptionAddress eventTrace globalParticipant false world - else world - (Cascade, world) - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription eventAddress globalParticipant world |> snd - (subscriptionAddress, unsubscribe, world) - { Subscribe = subscribe } - - /// Map over a stream by the given 'mapper' procedure. - let [] mapEvent - (mapper : Event<'a, 'g> -> 'w -> 'b) (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - let subscribe = fun (world : 'w) -> - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let subscriptionKey = makeGuid () - let subscriptionAddress = ntoa<'b> (scstring subscriptionKey) - let (eventAddress, unsubscribe, world) = stream.Subscribe world - let unsubscribe = fun world -> - let world = unsubscribe world - EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let subscription = fun evt world -> - let eventTrace = EventTrace.record "Stream" "mapEvent" evt.Trace - let world = EventWorld.publishPlus<'b, 'g, 'g, 'w> EventWorld.sortSubscriptionsNone (mapper evt world) subscriptionAddress eventTrace globalParticipant false world - (Cascade, world) - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription eventAddress globalParticipant world |> snd - (subscriptionAddress, unsubscribe, world) - { Subscribe = subscribe } - - (* World-Accessing Combinators *) - - let [] trackWorld4 - (tracker : 'c -> 'a -> 'w -> 'c * bool) (transformer : 'c -> 'b) (state : 'c) (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - trackEvent4 (fun c evt world -> tracker c evt.Data world) transformer state stream - - let [] trackWorld2 - (tracker : 'a -> 'a -> 'w -> 'a * bool) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - trackEvent2 (fun a evt world -> tracker a evt.Data world) stream - - let [] trackWorld - (tracker : 'b -> 'w -> 'b * bool) (state : 'b) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - trackEvent tracker state stream - - /// Fold over a stream, then map the result. - let [] foldMapWorld (f : 'b -> 'a -> 'w -> 'b) g s (stream : Stream<'a, 'g, 'w>) : Stream<'c, 'g, 'w> = - foldMapEvent (fun b evt world -> f b evt.Data world) g s stream - - /// Fold over a stream, aggegating the result. - let [] foldWorld (f : 'b -> 'a -> 'w -> 'b) s (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - foldEvent (fun b evt world -> f b evt.Data world) s stream - - /// Reduce over a stream, accumulating the result. - let [] reduceWorld (f : 'a -> 'a -> 'w -> 'a) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - reduceEvent (fun a evt world -> f a evt.Data world) stream - - /// Filter a stream by the given 'pred' procedure. - let [] filterWorld (pred : 'a -> 'w -> bool) (stream : Stream<'a, 'g, 'w>) = - filterEvent (fun evt world -> pred evt.Data world) stream - - /// Map over a stream by the given 'mapper' procedure. - let [] mapWorld (mapper : 'a -> 'w -> 'b) (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - mapEvent (fun evt world -> mapper evt.Data world) stream - - (* Primitive Combinators *) - - let [] track4 - (tracker : 'c -> 'a -> 'c * bool) (transformer : 'c -> 'b) (state : 'c) (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - trackEvent4 (fun c evt _ -> tracker c evt.Data) transformer state stream - - let [] track2 - (tracker : 'a -> 'a -> 'a * bool) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - trackEvent2 (fun a evt _ -> tracker a evt.Data) stream - - let [] track - (tracker : 'b -> 'b * bool) (state : 'b) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - trackEvent (fun b _ -> tracker b) state stream - - /// Fold over a stream, then map the result. - let [] foldMap (f : 'b -> 'a -> 'b) g s (stream : Stream<'a, 'g, 'w>) : Stream<'c, 'g, 'w> = - foldMapEvent (fun b evt _ -> f b evt.Data) g s stream - - /// Fold over a stream, aggegating the result. - let [] fold (f : 'b -> 'a -> 'b) s (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - foldEvent (fun b evt _ -> f b evt.Data) s stream - - /// Reduce over a stream, accumulating the result. - let [] reduce (f : 'a -> 'a -> 'a) (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - reduceEvent (fun a evt _ -> f a evt.Data) stream - - /// Filter a stream by the given 'pred' procedure. - let [] filter (pred : 'a -> bool) (stream : Stream<'a, 'g, 'w>) = - filterEvent (fun evt _ -> pred evt.Data) stream - - /// Map over a stream by the given 'mapper' procedure. - let [] map (mapper : 'a -> 'b) (stream : Stream<'a, 'g, 'w>) : Stream<'b, 'g, 'w> = - mapEvent (fun evt _ -> mapper evt.Data) stream - - /// Combine two streams. Combination is in 'product form', which is defined as a pair of the data of the combined - /// events. Think of it as 'zip' for event streams. - let [] product - (stream : Stream<'a, 'g, 'w>) (stream' : Stream<'b, 'g, 'w>) : Stream<'a * 'b, 'g, 'w> = - let subscribe = fun (world : 'w) -> - - // initialize event state, subscription keys and addresses - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let stateKey = makeGuid () - let state = (List.empty<'a>, List.empty<'b>) - let world = EventWorld.addEventState stateKey state world - let subscriptionKey = makeGuid () - let subscriptionKey' = makeGuid () - let subscriptionKey'' = makeGuid () - let (subscriptionAddress, unsubscribe, world) = stream.Subscribe world - let (subscriptionAddress', unsubscribe', world) = stream'.Subscribe world - let subscriptionAddress'' = ntoa<'a * 'b> (scstring subscriptionKey'') - - // unsubscribe from 'a and 'b events, and remove event state - let unsubscribe = fun world -> - let world = unsubscribe (unsubscribe' world) - let world = EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let world = EventWorld.unsubscribe<'g, 'w> subscriptionKey' world - EventWorld.removeEventState stateKey world - - // subscription for 'a events - let subscription = fun evt world -> - let eventTrace = EventTrace.record4 "Stream" "product" "'a" evt.Trace - let (aList : 'a list, bList : 'b list) = EventWorld.getEventState stateKey world - let aList = evt.Data :: aList - let (state, world) = - match (List.rev aList, List.rev bList) with - | (a :: aList, b :: bList) -> - let state = (aList, bList) - let world = EventWorld.publishPlus<'a * 'b, 'g, 'g, _> EventWorld.sortSubscriptionsNone (a, b) subscriptionAddress'' eventTrace globalParticipant false world - (state, world) - | state -> (state, world) - let world = EventWorld.addEventState stateKey state world - (Cascade, world) - - // subscription for 'b events - let subscription' = fun evt world -> - let eventTrace = EventTrace.record4 "Stream" "product" "'b" evt.Trace - let (aList : 'a list, bList : 'b list) = EventWorld.getEventState stateKey world - let bList = evt.Data :: bList - let (state, world) = - match (List.rev aList, List.rev bList) with - | (a :: aList, b :: bList) -> - let state = (aList, bList) - let world = EventWorld.publishPlus<'a * 'b, 'g, 'g, _> EventWorld.sortSubscriptionsNone (a, b) subscriptionAddress'' eventTrace globalParticipant false world - (state, world) - | state -> (state, world) - let world = EventWorld.addEventState stateKey state world - (Cascade, world) - - // subscripe 'a and 'b events - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription subscriptionAddress globalParticipant world |> snd - let world = EventWorld.subscribePlus<'b, 'g, 'g, 'w> subscriptionKey subscription' subscriptionAddress' globalParticipant world |> snd - (subscriptionAddress'', unsubscribe, world) - - // fin - { Subscribe = subscribe } - - /// Combine two streams. Combination is in 'sum form', which is defined as an Either of the data of the combined - /// events, where only data from the most recent event is available at a time. - let [] sum - (stream : Stream<'a, 'g, 'w>) (stream' : Stream<'b, 'g, 'w>) : Stream, 'g, 'w> = - let subscribe = fun world -> - let subscriptionKey = makeGuid () - let subscriptionKey' = makeGuid () - let subscriptionKey'' = makeGuid () - let (subscriptionAddress, unsubscribe, world) = stream.Subscribe world - let (subscriptionAddress', unsubscribe', world) = stream'.Subscribe world - let subscriptionAddress'' = ntoa> (scstring subscriptionKey'') - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let unsubscribe = fun world -> - let world = unsubscribe (unsubscribe' world) - let world = EventWorld.unsubscribe<'g, 'w> subscriptionKey world - EventWorld.unsubscribe<'g, 'w> subscriptionKey' world - let subscription = fun evt world -> - let eventTrace = EventTrace.record "Stream" "sum" evt.Trace - let eventData = Left evt.Data - let world = EventWorld.publishPlus, 'g, 'g, _> EventWorld.sortSubscriptionsNone eventData subscriptionAddress'' eventTrace globalParticipant false world - (Cascade, world) - let subscription' = fun evt world -> - let eventTrace = EventTrace.record "Stream" "sum" evt.Trace - let eventData = Right evt.Data - let world = EventWorld.publishPlus, 'g, 'g, _> EventWorld.sortSubscriptionsNone eventData subscriptionAddress'' eventTrace globalParticipant false world - (Cascade, world) - let world = EventWorld.subscribePlus<'b, 'g, 'g, 'w> subscriptionKey' subscription' subscriptionAddress' globalParticipant world |> snd - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey subscription subscriptionAddress globalParticipant world |> snd - (subscriptionAddress'', unsubscribe, world) - { Subscribe = subscribe } - - /// Terminate a stream when a given stream receives a value. - let [] until - (stream : Stream<'b, 'g, 'w>) (stream' : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - let subscribe = fun (world : 'w) -> - let globalParticipant = world.GetEventSystem () |> EventSystem.getGlobalPariticipant :?> 'g - let subscriptionKey = makeGuid () - let subscriptionKey' = makeGuid () - let subscriptionKey'' = makeGuid () - let (subscriptionAddress, unsubscribe, world) = stream.Subscribe world - let (subscriptionAddress', unsubscribe', world) = stream'.Subscribe world - let subscriptionAddress'' = ntoa<'a> (scstring subscriptionKey'') - let unsubscribe = fun world -> - let world = unsubscribe (unsubscribe' world) - let world = EventWorld.unsubscribe<'g, 'w> subscriptionKey' world - EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let subscription = fun _ world -> - let world = unsubscribe world - (Cascade, world) - let subscription' = fun evt world -> - let eventTrace = EventTrace.record "Stream" "until" evt.Trace - let world = EventWorld.publishPlus<'a, 'g, 'g, 'w> EventWorld.sortSubscriptionsNone evt.Data subscriptionAddress'' eventTrace globalParticipant false world - (Cascade, world) - let world = EventWorld.subscribePlus<'a, 'g, 'g, 'w> subscriptionKey' subscription' subscriptionAddress' globalParticipant world |> snd - let world = EventWorld.subscribePlus<'b, 'g, 'g, 'w> subscriptionKey subscription subscriptionAddress globalParticipant world |> snd - (subscriptionAddress'', unsubscribe, world) - { Subscribe = subscribe } - - /// Terminate a stream when the subscriber is unregistered from the world. - let [] lifetime<'s, 'a, 'g, 'w when 's :> Participant and 'w :> EventWorld<'g, 'w>> - (subscriber : 's) (stream_ : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - let removingEventAddress = ltoa [typeof<'s>.Name; "Unregistering"; "Event"] ->>- subscriber.ParticipantAddress - let removingStream = stream removingEventAddress - until removingStream stream_ - - /// Subscribe to a stream, handling each event with the given subscription, - /// returning both an unsubscription procedure as well as the world as augmented with said - /// subscription. - let [] subscribePlus subscription (subscriber : 's) stream world = - let subscribe = fun world -> - let subscriptionKey = makeGuid () - let subscriptionAddress = ntoa<'a> (scstring subscriptionKey) - let (address, unsubscribe, world) = stream.Subscribe world - let unsubscribe = fun world -> - let world = unsubscribe world - EventWorld.unsubscribe<'g, 'w> subscriptionKey world - let world = EventWorld.subscribePlus<'a, 's, 'g, 'w> subscriptionKey subscription address subscriber world |> snd - (subscriptionAddress, unsubscribe, world) - let stream = { Subscribe = subscribe } - stream.Subscribe world |> _bc - - /// Subscribe to a stream, handling each event with the given subscription. - let [] subscribe subscription subscriber stream world = - subscribePlus (fun evt world -> (Cascade, subscription evt world)) subscriber stream world |> snd - - /// Subscribe to a stream until the subscriber is removed from the world, - /// returning both an unsubscription procedure as well as the world as augmented with said - /// subscription. - let [] monitorPlus subscription subscriber stream world = - (stream |> lifetime subscriber |> subscribePlus subscription subscriber) world - - /// Subscribe to a stream until the subscriber is removed from the world. - let [] monitor subscription subscriber stream world = - monitorPlus (fun evt world -> (Cascade, subscription evt world)) subscriber stream world |> snd - - (* Derived Combinators *) - - /// Transform a stream into a running average of its event's numeric data. - let [] inline average (stream : Stream<'a, 'g, 'w>) : Stream<'a, 'g, 'w> = - foldMap - (fun (avg : 'a, den : 'a) a -> - let den' = den + one () - let dod' = den / den' - let avg' = avg * dod' + a / den - (avg', den')) - fst - (zero (), zero ()) - stream - - /// Transform a stream into a running map from its event's data to keys as defined by 'f'. - let [] organize f (stream : Stream<'a, 'g, 'w>) : Stream<('a * 'b) option * Map<'b, 'a>, 'g, 'w> = - fold - (fun (_, m) a -> - let b = f a - if Map.containsKey b m - then (None, m) - else (Some (a, b), Map.add b a m)) - (None, Map.empty) - stream - - /// Transform a stream into a running set of its event's unique data as defined via 'by'. - let [] groupBy by (stream : Stream<'a, 'g, 'w>) : Stream<'b * bool * 'b Set, 'g, 'w> = - fold - (fun (_, _, set) a -> - let b = by a - if Set.contains b set - then (b, false, set) - else (b, true, Set.add b set)) - (Unchecked.defaultof<'b>, false, Set.empty) - stream - - /// Transform a stream into a running set of its event's unique data. - let [] group (stream : Stream<'a, 'g, 'w>) : Stream<'a * bool * 'a Set, 'g, 'w> = - groupBy id stream - - /// Transform a stream into a running sum of its data. - let [] inline sumN stream = reduce (+) stream - - /// Transform a stream into a running product of its data. - let [] inline productN stream = reduce (*) stream - - /// Transform a stream of pairs into its fst values. - let [] first stream = map fst stream - - /// Transform a stream of pairs into its snd values. - let [] second stream = map snd stream - - /// Transform a stream's pairs by a mapping of its fst values. - let [] mapFirst mapper stream = map (fun a -> (mapper (fst a), snd a)) stream - - /// Transform a stream of pairs by a mapping of its snd values. - let [] mapSecond mapper stream = map (fun a -> (fst a, mapper (snd a))) stream - - /// Transform a stream by duplicating its data into pairs. - let [] duplicate stream = map (fun a -> (a, a)) stream - - /// Take only the first n events from a stream. - let [] take n stream = track (fun m -> (m + 1, m < n)) 0 stream - - /// Skip the first n events in a stream. - let [] skip n stream = track (fun m -> (m + 1, m >= n)) 0 stream - - /// Take only the first event from a stream. - let [] head stream = take 1 stream - - /// Skip the first event of a stream. - let [] tail stream = skip 1 stream - - /// Take only the nth event from a stream. - let [] nth n stream = stream |> skip n |> head - - /// Take only the first event from a stream that satisfies 'p'. - let [] search p stream = stream |> filter p |> head - - /// Filter out the None data values from a stream and strip the Some constructor from - /// the remaining values. - let [] choose (stream : Stream<'a option, 'g, 'w>) = - stream |> filter Option.isSome |> map Option.get - - /// Transform a stream into a running maximum of it numeric data. - let [] max stream = reduce (fun n a -> if n < a then a else n) stream - - /// Transform a stream into a running minimum of it numeric data. - let [] min stream = reduce (fun n a -> if a < n then a else n) stream - - /// Filter out the events with non-unique data as defined via 'by' from a stream. - let [] distinctBy by stream = stream |> organize by |> first |> choose - - /// Filter out the events with non-unique data from a stream. - let [] distinct stream = distinctBy id stream - -[] -module StreamOperators = - - // open related module - open Stream - - /// Stream sequencing operator. - let (---) = (|>) - - /// Make a stream of the subscriber's change events. - let [] (!--) (property : PropertyTag<'a, 'b, 'w>) = - let changeEventAddress = ltoa> [typeof<'a>.Name; "Change"; property.Name; "Event"] ->>- property.This.ParticipantAddress - stream changeEventAddress --- mapEvent (fun _ world -> property.Get world) - - /// Propagate the event data of a stream to a property in the observing participant when the - /// subscriber exists (doing nothing otherwise). - let [] (-->) stream (property : PropertyTag<'a, 'b, 'w>) = - subscribe (fun a world -> - if world.ParticipantExists a.Subscriber then - match property.SetOpt with - | Some set -> set a.Data world - | None -> world // TODO: log info here about property not being set-able? - else world) - property.This - stream \ No newline at end of file diff --git a/Prime/Prime/String.fs b/Prime/Prime/String.fs deleted file mode 100644 index f263abbf4f..0000000000 --- a/Prime/Prime/String.fs +++ /dev/null @@ -1,175 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Text - -[] -module String = - - /// Check that a string is empty. - let isEmpty str = - String.length str = 0 - - /// Check that a string is not empty. - let notEmpty str = - String.length str > 0 - - /// Check that a string is a guid. - let isGuid str = - fst (Guid.TryParse str) - - /// Convert a bool to a string that works well in code. - let boolToCodeString (bool : bool) = - if bool then "true" else "false" - - /// Convert an int64 to a string that works well in code. - let int64ToCodeString (num : int64) = - let numStr = string num - numStr + "L" - - /// Convert a single to a string that works well in code. - let singleToCodeString (num : single) = - if not (Single.IsNaN num) then - let decimaled = num.ToString ("N7") - let cleaned = decimaled.TrimEnd('0').Replace(",","") - let zeroed = if cleaned.EndsWith "." then cleaned + "0" else cleaned - zeroed + "f" - else string num - - /// Convert a double to a string that works well in code. - let doubleToCodeString (num : double) = - if not (Double.IsNaN num) then - let decimaled = num.ToString ("N15") - let cleaned = decimaled.TrimEnd('0').Replace(",","") - if cleaned.EndsWith "." then cleaned + "0" else cleaned - else string num - - /// Convert a number to a string that works well in code. - let numberToCodeString (num : obj) = - match num with - | :? bool as bool -> boolToCodeString bool - | :? char as char -> string char - | :? int as int -> string int - | :? int64 as int64 -> int64ToCodeString int64 - | :? single as single -> singleToCodeString single - | :? double as double -> doubleToCodeString double - | _ -> failwithumf () - - /// Converts a string into a list of characters. - let explode (str : string) = - let rec loop n acc = - if n = 0 then acc - else - let n = n - 1 - loop n (str.[n] :: acc) - loop (String.length str) [] - - /// Converts a list of characters into a string. - let implode chars = - let sb = StringBuilder () - List.iter (fun (chr : char) -> sb.Append chr |> ignore) chars - sb.ToString () - - /// Capitalize a string. - let capitalize (str : string) = - match str.ToCharArray () |> List.ofArray with - | [] -> str - | [head] -> [|Char.ToUpperInvariant head|] |> String - | head :: tail -> Char.ToUpperInvariant head :: tail |> Array.ofList |> String - - /// Textualize a string for usage as text. - let textualize (str : string) = - str.Replace('_', '\"') - - /// Get the string with the given ending. - let withEnd str target = - let length = String.length str - let endLength = String.length target - if endLength >= length then (false, String.Empty) - else - let beginLength = length - endLength - let beginStr = str.Substring (0, beginLength) - let endStr = str.Substring (beginLength, endLength) - (endStr = target, beginStr) - - /// Convert a string to an array of characters. - let toArray str = Array.ofList (explode str) - - /// Surround a string with another surrounding string. - let surround (str : string) (surrounding : string) = - surrounding + str + surrounding - - /// Contract escaped characters in a string. - let unescape (str : string) = - let unescaped = - Seq.fold (fun (escaped, chars) y -> - if escaped then - let chr = - match y with - | '0' -> '\u0000' - | '\\' -> '\\' - | 'a' -> '\a' - | 'b' -> '\b' - | 'f' -> '\u000c' - | 'n' -> '\n' - | 'r' -> '\r' - | 't' -> '\t' - | 'v' -> '\v' - | c -> c - (false, chr :: chars) - elif y = '\\' then (true, chars) - else (false, y :: chars)) - (false, []) - str - unescaped |> snd |> List.rev |> implode - - /// Expand escaped characters in a string. - let escape (str : string) = - // NOTE: doing escape character substitution in-place with a linked-list may prevent speed issues - str - .Replace("\\", "\\\\") // NOTE: this line must come first - .Replace("\u0000", "\\0") - .Replace("\a", "\\a") - .Replace("\b", "\\b") - .Replace("\f", "\\f") - .Replace("\n", "\\n") - .Replace("\r", "\\r") - .Replace("\t", "\\t") - .Replace("\v", "\\v") - - /// Check that a name ends with a Guid. - let endsWithGuid str = - if String.length str >= 36 then - let last36 = str.Substring (str.Length - 36, 36) - Guid.TryParse last36 |> fst - else false - - /// Query for equality a list of string lexicographically. - let rec equateMany (strs : string list) (strs2 : string list) = - match (strs, strs2) with - | ([], []) -> true - | (_ :: _, []) -> false - | ([], _ :: _) -> false - | (head :: tail, head2 :: tail2) -> - let result = strEq head head2 - if result then equateMany tail tail2 - else result - - /// Compare a list of string lexicographically. - let rec compareMany (strs : string list) (strs2 : string list) = - match (strs, strs2) with - | ([], []) -> 0 - | (_ :: _, []) -> 1 - | ([], _ :: _) -> -1 - | (head :: tail, head2 :: tail2) -> - let result = strCmp head head2 - if result = 0 then compareMany tail tail2 - else result - - /// Hash a list of names. - let hashMany (strs : string list) = - let mutable hashValue = 0 // OPTIMIZATION: mutation for speed - for name in strs do hashValue <- hashValue ^^^ hash name - hashValue \ No newline at end of file diff --git a/Prime/Prime/Symbol.fs b/Prime/Prime/Symbol.fs deleted file mode 100644 index c0de514742..0000000000 --- a/Prime/Prime/Symbol.fs +++ /dev/null @@ -1,494 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Reflection -open FParsec -open Prime - -type SymbolSource = - { FileNameOpt : string option - Text : string } - -type SymbolState = - { SymbolSource : SymbolSource } - -type SymbolOrigin = - { Source : SymbolSource - Start : Position - Stop : Position } - -[] -module SymbolOrigin = - - let printStart origin = - "[Ln: " + string origin.Start.Line + ", Col: " + string origin.Start.Column + "]" - - let printStop origin = - "[Ln: " + string origin.Stop.Line + ", Col: " + string origin.Stop.Column + "]" - - let printContext origin = - try // there's more than one thing that can go wrong in here... - let sourceLines = origin.Source.Text.Split '\n' - let problemLineIndex = int origin.Start.Line - 1 - let problemLinesStartCount = problemLineIndex - Math.Max (0, problemLineIndex - 3) - let problemLinesStart = - sourceLines |> - Array.trySkip (problemLineIndex - problemLinesStartCount) |> - Array.take (inc problemLinesStartCount) |> - String.concat "\n" |> - fun str -> if String.isEmpty str then "" else str + "\n" - let problemLinesStop = - sourceLines |> - Array.skip (inc problemLineIndex) |> - Array.tryTake 4 |> - String.concat "\n" |> - fun str -> if String.isEmpty str then "" else "\n" + str - let problemUnderline = - String.replicate (int origin.Start.Column - 1) " " + - if origin.Start.Line = origin.Stop.Line - then String.replicate (int origin.Stop.Column - int origin.Start.Column) "^" - else "^^^^^^^" // just use lots of carets... - problemLinesStart + problemUnderline + problemLinesStop - with exn -> - // ...and I don't feel like dealing with all the specifics. - "Error creating violation context." - - let print origin = - "At location: " + printStart origin + " thru " + printStop origin + "\n" + - "In context:\n" + - "\n" + - printContext origin - - let tryPrint originOpt = - match originOpt with - | Some origin -> print origin - | None -> "Error origin unknown or not applicable." - -type Symbol = - | Atom of string * SymbolOrigin option - | Number of string * SymbolOrigin option - | String of string * SymbolOrigin option - | Quote of Symbol * SymbolOrigin option - | Symbols of Symbol list * SymbolOrigin option - -[] -module Symbol = - - let [] NewlineChars = "\n\r" - let [] WhitespaceChars = "\t " + NewlineChars - let [] IndexChar = '.' - let [] IndexStr = "." - let [] OpenSymbolsChar = '[' - let [] OpenSymbolsStr = "[" - let [] CloseSymbolsChar = ']' - let [] CloseSymbolsStr = "]" - let [] OpenStringChar = '\"' - let [] OpenStringStr = "\"" - let [] CloseStringChar = '\"' - let [] CloseStringStr = "\"" - let [] QuoteChar = '`' - let [] QuoteStr = "`" - let [] LineCommentChar = ';' - let [] LineCommentStr = ";" - let [] OpenMultilineCommentStr = "#|" - let [] CloseMultilineCommentStr = "|#" - let [] IndexExpansion = "Index" - let [] ReservedChars = "(){}\\#$:," - let [] StructureCharsNoStr = "[]`." - let [] StructureChars = "\"" + StructureCharsNoStr - let (*Literal*) IllegalNameChars = ReservedChars + StructureChars + WhitespaceChars - let (*Literal*) IllegalNameCharsArray = Array.ofSeq IllegalNameChars - let [] NumberFormat = - NumberLiteralOptions.AllowMinusSign ||| - NumberLiteralOptions.AllowPlusSign ||| - NumberLiteralOptions.AllowExponent ||| - NumberLiteralOptions.AllowFraction ||| - NumberLiteralOptions.AllowHexadecimal ||| - NumberLiteralOptions.AllowSuffix - - let isWhitespaceChar chr = isAnyOf WhitespaceChars chr - let isStructureChar chr = isAnyOf StructureChars chr - let isExplicit (str : string) = str.StartsWith OpenStringStr && str.EndsWith CloseStringStr - let distillate (str : string) = (str.Replace (OpenStringStr, "")).Replace (CloseStringStr, "") - - let skipLineComment = skipChar LineCommentChar >>. skipRestOfLine true - let skipMultilineComment = - // TODO: make multiline comments nest. - between - (skipString OpenMultilineCommentStr) - (skipString CloseMultilineCommentStr) - (skipCharsTillString CloseMultilineCommentStr false System.Int32.MaxValue) - - let skipWhitespace = skipLineComment <|> skipMultilineComment <|> skipAnyOf WhitespaceChars - let skipWhitespaces = skipMany skipWhitespace - let followedByWhitespaceOrStructureCharOrAtEof = nextCharSatisfies (fun chr -> isWhitespaceChar chr || isStructureChar chr) <|> eof - - let startIndex = skipChar IndexChar - let startQuote = skipChar QuoteChar - let openSymbols = skipChar OpenSymbolsChar - let closeSymbols = skipChar CloseSymbolsChar - let openString = skipChar OpenStringChar - let closeString = skipChar CloseStringChar - - let isNumberParser = numberLiteral NumberFormat "number" >>. eof - let isNumber str = match run isNumberParser str with Success (_, _, position) -> position.Index = int64 str.Length | Failure _ -> false - let shouldBeExplicit str = Seq.exists (fun chr -> Char.IsWhiteSpace chr || Seq.contains chr StructureCharsNoStr) str - - let readAtomChars = many1 (noneOf (StructureChars + WhitespaceChars)) - let readStringChars = many (noneOf [CloseStringChar]) - let (readSymbol : Parser, private readSymbolRef : Parser ref) = createParserForwardedToRef () - - let readAtom = - parse { - let! userState = getUserState - let! start = getPosition - let! chars = readAtomChars - let! stop = getPosition - do! skipWhitespaces - let str = chars |> String.implode |> fun str -> str.TrimEnd () - let originOpt = Some { Source = userState.SymbolSource; Start = start; Stop = stop } - return Atom (str, originOpt) } - - let readNumber = - parse { - let! userState = getUserState - let! start = getPosition - let! number = numberLiteral NumberFormat "number" - do! followedByWhitespaceOrStructureCharOrAtEof - let! stop = getPosition - do! skipWhitespaces - let originOpt = Some { Source = userState.SymbolSource; Start = start; Stop = stop } - let suffix = - (if number.SuffixChar1 <> (char)65535 then string number.SuffixChar1 else "") + - (if number.SuffixChar2 <> (char)65535 then string number.SuffixChar2 else "") + - (if number.SuffixChar3 <> (char)65535 then string number.SuffixChar3 else "") + - (if number.SuffixChar4 <> (char)65535 then string number.SuffixChar4 else "") - return Number (number.String + suffix, originOpt) } - - let readString = - parse { - let! userState = getUserState - let! start = getPosition - do! openString - do! skipWhitespaces - let! escaped = readStringChars - do! closeString - let! stop = getPosition - do! skipWhitespaces - let str = escaped |> String.implode - let originOpt = Some { Source = userState.SymbolSource; Start = start; Stop = stop } - return String (str, originOpt) } - - let readQuote = - parse { - let! userState = getUserState - let! start = getPosition - do! startQuote - let! quoted = readSymbol - let! stop = getPosition - do! skipWhitespaces - let originOpt = Some { Source = userState.SymbolSource; Start = start; Stop = stop } - return Quote (quoted, originOpt) } - - let readSymbols = - parse { - let! userState = getUserState - let! start = getPosition - do! openSymbols - do! skipWhitespaces - let! symbols = many readSymbol - do! closeSymbols - let! stop = getPosition - do! skipWhitespaces - let originOpt = Some { Source = userState.SymbolSource; Start = start; Stop = stop } - return Symbols (symbols, originOpt) } - - let readIndex = - parse { - let! userState = getUserState - let! start = getPosition - do! startIndex - do! skipWhitespaces - let! stop = getPosition - do! skipWhitespaces - let originOpt = Some { Source = userState.SymbolSource; Start = start; Stop = stop } - return fun target indexer -> - match indexer with - | Symbols ([Number _ as number], _) -> Symbols ([Atom (IndexExpansion, originOpt); number; target], originOpt) - | _ -> Symbols ([Atom (IndexExpansion, originOpt); indexer; target], originOpt) } - - let readSymbolBirecursive = - attempt readQuote <|> - attempt readString <|> - attempt readNumber <|> - attempt readAtom <|> - readSymbols - - do readSymbolRef := - chainl1 readSymbolBirecursive readIndex - - let rec writeSymbol symbol = - match symbol with - | Atom (str, _) -> - let str = distillate str - if Seq.isEmpty str then OpenStringStr + CloseStringStr - elif not (isExplicit str) && shouldBeExplicit str then OpenStringStr + str + CloseStringStr - elif isExplicit str && not (shouldBeExplicit str) then str.Substring (1, str.Length - 2) - else str - | Number (str, _) -> distillate str - | String (str, _) -> OpenStringStr + distillate str + CloseStringStr - | Quote (symbol, _) -> QuoteStr + writeSymbol symbol - | Symbols (symbols, _) -> - match symbols with - | [Atom (str, _); Number _ as indexer; target] when str = IndexExpansion -> - writeSymbol target + IndexStr + OpenSymbolsStr + writeSymbol indexer + CloseSymbolsStr - | [Atom (str, _); indexer; target] when str = IndexExpansion -> - writeSymbol target + IndexStr + writeSymbol indexer - | _ -> - OpenSymbolsStr + String.concat " " (List.map writeSymbol symbols) + CloseSymbolsStr - - /// Convert a string to a symbol, with the following parses: - /// - /// (* Atom values *) - /// None - /// CharacterAnimationFacing - /// - /// (* Number values *) - /// 0.0f - /// -5 - /// - /// (* String value *) - /// "String with quoted spaces." - /// - /// (* Quoted value *) - /// `[Some 1] - /// - /// (* Symbols values *) - /// [] - /// [Some 0] - /// [Left 0] - /// [[0 1] [2 4]] - /// [AnimationData 4 8] - /// [Gem `[Some 1]] - /// - /// ...and so on. - let fromString str = - let symbolState = { SymbolSource = { FileNameOpt = None; Text = str }} - match runParserOnString (skipWhitespaces >>. readSymbol) symbolState String.Empty str with - | Success (value, _, _) -> value - | Failure (error, _, _) -> failwith error - - /// Convert a symbol to a string, with the following unparses: - /// - /// (* Atom values *) - /// None - /// CharacterAnimationFacing - /// - /// (* Number values *) - /// 0.0f - /// -5 - /// - /// (* String value *) - /// "String with quoted spaces." - /// - /// (* Quoted value *) - /// `[Some 1] - /// - /// (* Symbols values *) - /// [] - /// [Some 0] - /// [Left 0] - /// [[0 1] [2 4]] - /// [AnimationData 4 8] - /// [Gem `[Some 1]] - /// - /// ...and so on. - let rec toString symbol = writeSymbol symbol - - /// Try to get the Origin of the symbol if it has one. - let tryGetOrigin symbol = - match symbol with - | Atom (_, originOpt) - | Number (_, originOpt) - | String (_, originOpt) - | Quote (_, originOpt) - | Symbols (_, originOpt) -> originOpt - -/// Pretty prints Symbols, as well as strings by converting them to Symbols. -type PrettyPrinter = - { TitleWords : string Set - HeaderWords : string Set - DetailWords : string Set - ThresholdMin : int - ThresholdMax : int } - - static member defaulted = - { TitleWords = Set.empty - HeaderWords = Set.empty - DetailWords = Set.empty - ThresholdMin = Constants.PrettyPrinter.DefaultThresholdMin - ThresholdMax = Constants.PrettyPrinter.DefaultThresholdMax } - -[] -module PrettyPrinter = - - type private PrettySymbol = - | PrettyAtom of bool * bool * bool * string * Symbol - | PrettyNumber of string * Symbol - | PrettyString of string * Symbol - | PrettyIndex of int * PrettySymbol * PrettySymbol - | PrettyQuote of int * PrettySymbol - | PrettySymbols of bool * bool * int * PrettySymbol list - - let rec private getTitled prettySymbol = - match prettySymbol with - | PrettyAtom (titled, _, _, _, _) -> titled - | _ -> false - - let rec private getHeadered prettySymbol = - match prettySymbol with - | PrettyAtom (_, headered, _, _, _) -> headered - | _ -> false - - let rec private getDetailed prettySymbol = - match prettySymbol with - | PrettyAtom (_, _, detailed, _, _) -> detailed - | _ -> false - - let rec private getMaxDepth prettySymbol = - match prettySymbol with - | PrettyAtom _ -> 0 - | PrettyNumber _ -> 0 - | PrettyString _ -> 0 - | PrettyIndex _ -> 0 - | PrettyQuote (maxDepth, _) -> maxDepth - | PrettySymbols (_, _, maxDepth, _) -> maxDepth - - let rec private symbolToPrettySymbol symbol prettyPrinter = - match symbol with - | Atom (str, _) -> - PrettyAtom - (Set.contains str prettyPrinter.TitleWords, - Set.contains str prettyPrinter.HeaderWords, - Set.contains str prettyPrinter.DetailWords, - str, - symbol) - | Number (str, _) -> PrettyNumber (str, symbol) - | String (str, _) -> PrettyString (str, symbol) - | Quote (quoted, _) -> - let prettyQuoted = symbolToPrettySymbol quoted prettyPrinter - let maxDepth = getMaxDepth prettyQuoted - PrettyQuote (inc maxDepth, prettyQuoted) - | Symbols (symbols, _) -> - match symbols with - | [Atom ("Index", _); indexer; target] -> - let prettyIndexer = symbolToPrettySymbol indexer prettyPrinter - let prettyTarget = symbolToPrettySymbol target prettyPrinter - PrettyIndex (0, prettyIndexer, prettyTarget) - | _ -> - let prettySymbols = List.map (flip symbolToPrettySymbol prettyPrinter) symbols - let titled = match prettySymbols with head :: _ -> getTitled head | [] -> false - let headered = match prettySymbols with head :: _ -> getHeadered head | [] -> false - let detailed = match prettySymbols with head :: _ -> getDetailed head | [] -> false - let maxDepths = 0 :: List.map getMaxDepth prettySymbols - let maxDepth = List.max maxDepths - let maxDepth = if headered || detailed then maxDepth else maxDepth + 1 - PrettySymbols (titled, headered, maxDepth, prettySymbols) - - let rec private prettySymbolsToPrettyStr titled headered depth unfolding symbols prettyPrinter = - if unfolding then - let symbolsLength = List.length symbols - let prettyStrs = - List.mapi (fun i prettySymbol -> - let whitespace = - if titled then - if i > 1 then "\n" + String.init (inc depth) (fun _ -> " ") - elif i > 0 then " " - else "" - elif headered then - if i = dec symbolsLength then "\n" + String.init (inc depth) (fun _ -> " ") - elif i > 0 then " " - else "" - else - if i > 0 then "\n" + String.init (inc depth) (fun _ -> " ") - else "" - let text = prettySymbolToPrettyStr (inc depth) prettySymbol prettyPrinter - whitespace + text) - symbols - let prettyStr = Symbol.OpenSymbolsStr + String.concat "" prettyStrs + Symbol.CloseSymbolsStr - prettyStr - else - let prettyStrs = - List.map (fun prettySymbol -> - prettySymbolToPrettyStr (inc depth) prettySymbol prettyPrinter) - symbols - let prettyStr = Symbol.OpenSymbolsStr + String.concat " " prettyStrs + Symbol.CloseSymbolsStr - prettyStr - - and private prettySymbolToPrettyStr depth prettySymbol prettyPrinter = - match prettySymbol with - | PrettyAtom (_, _, _, _, symbol) - | PrettyNumber (_, symbol) - | PrettyString (_, symbol) -> Symbol.writeSymbol symbol - | PrettyIndex (depth, prettyIndexer, prettyTarget) -> - let prettyIndexerStr = prettySymbolToPrettyStr depth prettyIndexer prettyPrinter - let prettyTargetStr = prettySymbolToPrettyStr depth prettyTarget prettyPrinter - match prettyIndexer with - | PrettyNumber _ -> prettyTargetStr + Symbol.IndexStr + Symbol.OpenSymbolsStr + prettyIndexerStr + Symbol.CloseSymbolsStr - | _ -> prettyTargetStr + Symbol.IndexStr + prettyIndexerStr - | PrettyQuote (_, prettySymbol) -> - let prettyStr = prettySymbolToPrettyStr (inc depth) prettySymbol prettyPrinter - Symbol.QuoteStr + prettyStr - | PrettySymbols (titled, headered, maxDepth, symbols) -> - let unfolding = depth < prettyPrinter.ThresholdMin || maxDepth > prettyPrinter.ThresholdMax - prettySymbolsToPrettyStr titled headered depth unfolding symbols prettyPrinter - - let prettyPrintSymbol symbol prettyPrinter = - let prettySymbol = symbolToPrettySymbol symbol prettyPrinter - prettySymbolToPrettyStr 0 prettySymbol prettyPrinter - - let prettyPrint str prettyPrinter = - let symbol = Symbol.fromString str - prettyPrintSymbol symbol prettyPrinter - -type [] - SyntaxAttribute - (keywords0 : string, - keywords1 : string, - titleWordsStr : string, - headerWordsStr : string, - detailWordsStr : string, - prettyPrinterThresholdMin : int, - prettyPrinterThresholdMax : int) = - inherit Attribute () - member this.Keywords0 = keywords0 - member this.Keywords1 = keywords1 - member this.PrettyPrinter = - { TitleWords = Set.ofArray (titleWordsStr.Split ' ') - HeaderWords = Set.ofArray (headerWordsStr.Split ' ') - DetailWords = Set.ofArray (detailWordsStr.Split ' ') - ThresholdMin = prettyPrinterThresholdMin - ThresholdMax = prettyPrinterThresholdMax } - static member getOrDefault (ty : Type) = - match ty.GetCustomAttribute true with - | null -> - SyntaxAttribute - ("", "", "", "", "", - PrettyPrinter.defaulted.ThresholdMin, - PrettyPrinter.defaulted.ThresholdMax) - | syntax -> syntax - -type ConversionException (message : string, symbolOpt : Symbol option) = - inherit Exception (message) - member this.SymbolOpt = symbolOpt - override this.ToString () = - message + "\n" + - (match symbolOpt with Some symbol -> SymbolOrigin.tryPrint (Symbol.tryGetOrigin symbol) + "\n" | _ -> "") + - base.ToString () - -[] -module ConversionExceptionOperators = - let failconv message symbolOpt = - raise (ConversionException (message, symbolOpt)) \ No newline at end of file diff --git a/Prime/Prime/SymbolTests.fs b/Prime/Prime/SymbolTests.fs deleted file mode 100644 index 2857fc3fad..0000000000 --- a/Prime/Prime/SymbolTests.fs +++ /dev/null @@ -1,114 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime.Tests -open System -open Xunit -open Prime - -type IntIntRecord = { Int : int; Int2 : int } - -[] -type IntIntRecordExpanded = { IntX : int; IntX2 : int } - -type SimpleUnion = - | SimpleUnion - | SimpleUnion2 - -type [] ComplexUnion = - | ComplexUnion of int - | ComplexUnion2 of int * int - -module SymbolTests = - - let [] canConvertStringToAtom () = - let converter = SymbolicConverter (true, None, typeof) - match converter.ConvertFromString "atom" :?> Symbol with - | Atom (str, _) -> Assert.Equal ("atom", str) - | _ -> Assert.True false - - let [] canConvertStringToNumber () = - let converter = SymbolicConverter (true, None, typeof) - match converter.ConvertFromString "0" :?> Symbol with - | Number (str, _) -> Assert.Equal ("0", str) - | _ -> Assert.True false - - let [] canConvertStringToNegativeNumber () = - let converter = SymbolicConverter (true, None, typeof) - match converter.ConvertFromString "-1" :?> Symbol with - | Number (str, _) -> Assert.Equal ("-1", str) - | _ -> Assert.True false - - let [] canConvertStringToString () = - let converter = SymbolicConverter (true, None, typeof) - match converter.ConvertFromString "\"str\"" :?> Symbol with - | String (str, _) -> Assert.Equal ("str", str) - | _ -> Assert.True false - - let [] canConvertStringToInt () = - let value = scvalue "0" - Assert.Equal (0, value) - - let [] canConvertStringToNone () = - let value = scvalue "None" - Assert.Equal (None, value) - - let [] canConvertStringToSomeString () = - let value = scvalue "[Some string]" - Assert.Equal (Some "string", value) - - let [] canConvertStringToRightString () = - let value = scvalue> "[Right string]" - Assert.Equal> (Right "string", value) - - let [] canConvertStringToIntList () = - let value = scvalue "[0 1]" - Assert.Equal ([0; 1], value) - - let [] canConvertStringToIntListList () = - let value = scvalue "[[]]" - Assert.Equal ([[]], value) - - let [] canConvertStringToIntListListEmpty () = - let value = scvalue "[]" - Assert.Equal ([], value) - - let [] canConvertStringToTuple () = - let value = scvalue "[0 1]" - Assert.Equal ((0, 1), value) - - let [] canConvertStringToTupleTuple () = - let value = scvalue<(int * int) * (int * int)> "[[0 1] [2 3]]" - Assert.Equal (((0, 1), (2, 3)), value) - - let [] canConvertStringToRecord () = - let value = scvalue "[0 1]" - Assert.Equal ({ Int = 0; Int2 = 1 }, value) - - let [] canConvertStringToExpandedRecord () = - let value = scvalue "[[IntX 0] [IntX2 1]]" - Assert.Equal ({ IntX = 0; IntX2 = 1 }, value) - - let [] canConvertStringToSimpleUnion () = - let value = scvalue "SimpleUnion" - Assert.Equal (SimpleUnion, value) - - let [] canConvertStringToComplexUnion () = - let value = scvalue "[ComplexUnion 0]" - Assert.Equal (ComplexUnion 0, value) - - let [] canConvertStringToComplexUnionTuple () = - let value = scvalue "[[ComplexUnion 0] [ComplexUnion2 1 2]]" - // each tuple element must be tested individually as Assert.Equal doesn't seem to support tuple unions... - Assert.Equal (ComplexUnion 0, fst value) - Assert.Equal (ComplexUnion2 (1, 2), snd value) - - let [] canConvertStringToMapIntInt () = - let value = scvalue> "[[0 1]]" - Assert.Equal (1, Map.find 0 value) - - let [] canPrettyPrintGuid () = - let prettyPrinter = (SyntaxAttribute.getOrDefault typeof).PrettyPrinter - let symbolStr = "[5ec8734f-6a3d-4472-b86a-78125d238dc2]" - let prettyStr = PrettyPrinter.prettyPrint symbolStr prettyPrinter - Assert.Equal (symbolStr, prettyStr) \ No newline at end of file diff --git a/Prime/Prime/SymbolicConverter.fs b/Prime/Prime/SymbolicConverter.fs deleted file mode 100644 index 0c663c09b3..0000000000 --- a/Prime/Prime/SymbolicConverter.fs +++ /dev/null @@ -1,430 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic -open System.ComponentModel -open System.Reflection -open Microsoft.FSharp.Reflection -open Prime - -/// Expands a record so that its fields are named. -type SymbolicExpansionAttribute () = - inherit Attribute () - -/// Compresses two unions into a single union in a symbolic-expression. -type SymbolicCompression<'a, 'b> = - | SymbolicCompressionA of 'a - | SymbolicCompressionB of 'b - -type SymbolicConverter (printing : bool, designTypeOpt : Type option, pointType : Type) = - inherit TypeConverter () - - let padWithDefaults' (fieldTypes : Type array) (values : obj array) = - if values.Length < fieldTypes.Length then - let valuesPadded = - fieldTypes |> - Array.skip values.Length |> - Array.map (fun info -> info.GetDefaultValue ()) |> - Array.append values - valuesPadded - else values - - let padWithDefaults (fieldInfos : PropertyInfo array) (values : obj array) = - padWithDefaults' (Array.map (fun (info : PropertyInfo) -> info.PropertyType) fieldInfos) values - - let rec toSymbol (sourceType : Type) (source : obj) = - match sourceType.TryGetCustomTypeConverter () with - | Some typeConverter -> - - // symbolize user-defined type - if not (typeConverter.CanConvertTo typeof) - then failconv ("Cannot convert type '" + getTypeName source + "' to Prime.Symbol.") None - else typeConverter.ConvertTo (source, typeof) :?> Symbol - - | None -> - - // symbolize .NET primitive - if sourceType.IsPrimitive then - let converted = (TypeDescriptor.GetConverter sourceType).ConvertTo (source, typeof) :?> string - if sourceType = typeof then Atom (converted, None) - elif sourceType = typeof then String (converted, None) - else Number (converted, None) - - // symbolize string - elif sourceType = typeof then - if printing then - let sourceStr = string source - if pointType = typeof then String (sourceStr, None) - elif Symbol.isNumber sourceStr then Number (sourceStr, None) - else Atom (sourceStr, None) - else - let sourceStr = string source - if Symbol.shouldBeExplicit sourceStr then String (sourceStr, None) - elif Symbol.isNumber sourceStr then Number (sourceStr, None) - else Atom (sourceStr, None) - - // symbolize Symbol (no transformation) - elif sourceType = typeof then - source :?> Symbol - - // symbolize KeyValuePair - elif sourceType.Name = typedefof>.Name then - let gargs = sourceType.GetGenericArguments () - let kvp = Reflection.objToKeyValuePair source - let keySymbol = toSymbol gargs.[0] kvp.Key - let valueSymbol = toSymbol gargs.[1] kvp.Value - Symbols ([keySymbol; valueSymbol], None) - - // symbolize DesignerProperty - elif sourceType = typeof then - let property = source :?> DesignerProperty - let nameString = String (property.DesignerType.AssemblyQualifiedName, None) - let valueSymbol = toSymbol property.DesignerType property.DesignerValue - if Option.isSome designTypeOpt then valueSymbol - else Symbols ([nameString; valueSymbol], None) - - // symbolize array - elif sourceType.IsArray then - let items = Reflection.objToObjList source - let symbols = List.map (toSymbol (sourceType.GetElementType ())) items - Symbols (symbols, None) - - // symbolize unit - elif sourceType.Name = typeof.Name then - Symbols ([], None) - - // symbolize list - elif sourceType.Name = typedefof<_ list>.Name then - let gargs = sourceType.GetGenericArguments () - let items = Reflection.objToObjList source - let symbols = List.map (toSymbol gargs.[0]) items - Symbols (symbols, None) - - // symbolize Set - elif sourceType.Name = typedefof<_ Set>.Name then - let gargs = sourceType.GetGenericArguments () - let items = Reflection.objToComparableSet source |> List.ofSeq - let symbols = List.map (toSymbol gargs.[0]) items - Symbols (symbols, None) - - // symbolize Map - elif sourceType.Name = typedefof>.Name then - let gargs = sourceType.GetGenericArguments () - let itemType = typedefof>.MakeGenericType [|gargs.[0]; gargs.[1]|] - let items = Reflection.objToObjList source - let symbols = List.map (toSymbol itemType) items - Symbols (symbols, None) - - // symbolize SymbolicCompression - elif sourceType.Name = typedefof>.Name then - let (unionCase, unionFields) = FSharpValue.GetUnionFields (source, sourceType) - let value = unionFields.[0] - let valueType = value.GetType () - if unionCase.Tag = 0 then toSymbol valueType value - else - let (_, unionFields) = FSharpValue.GetUnionFields (value, valueType) - let value = unionFields.[0] - let valueType = value.GetType () - toSymbol valueType value - - // symbolize Tuple - elif FSharpType.IsTuple sourceType then - let tupleFields = FSharpValue.GetTupleFields source - let tupleElementTypes = FSharpType.GetTupleElements sourceType - let tupleFieldSymbols = Array.mapi (fun i tupleField -> toSymbol tupleElementTypes.[i] tupleField) tupleFields - Symbols (List.ofArray tupleFieldSymbols, None) - - // symbolize Record - elif FSharpType.IsRecord sourceType then - if sourceType.IsDefined (typeof, true) then - let recordFieldInfos = FSharpType.GetRecordFields sourceType - let recordFields = Array.map (fun info -> (info, FSharpValue.GetRecordField (source, info))) recordFieldInfos - let recordFieldSymbols = - recordFields |> - Array.map (fun (info, field) -> Symbols ([Atom (info.Name, None); toSymbol info.PropertyType field], None)) - Symbols (List.ofArray recordFieldSymbols, None) - else - let recordFields = FSharpValue.GetRecordFields source - let recordFieldTypes = FSharpType.GetRecordFields sourceType - let recordFieldSymbols = Array.mapi (fun i recordField -> toSymbol recordFieldTypes.[i].PropertyType recordField) recordFields - Symbols (List.ofArray recordFieldSymbols, None) - - // symbolize Union - elif FSharpType.IsUnion sourceType then - let (unionCase, unionFields) = FSharpValue.GetUnionFields (source, sourceType) - let unionFieldInfos = unionCase.GetFields () - if not (Array.isEmpty unionFields) then - let unionFieldSymbols = Array.mapi (fun i unionField -> toSymbol unionFieldInfos.[i].PropertyType unionField) unionFields - let unionSymbols = Array.cons (Atom (unionCase.Name, None)) unionFieldSymbols - Symbols (List.ofArray unionSymbols, None) - else Atom (unionCase.Name, None) - - // symbolize vanilla .NET type - else - let typeConverter = TypeDescriptor.GetConverter sourceType - match typeConverter with - | :? DateTimeConverter -> - // HACK: we do not want to use this converter here as it strips the time when converting to string! - let dateTimeStr = string source - String (dateTimeStr, None) - | _ -> - if typeConverter.CanConvertTo typeof - then typeConverter.ConvertTo (source, typeof) :?> Symbol - else (typeConverter.ConvertTo (source, typeof) :?> string, None) |> Atom - - let toString (sourceType : Type) (source : obj) = - let symbol = toSymbol sourceType source - Symbol.toString symbol - - let rec fromSymbol (destType : Type) (symbol : Symbol) = - - // desymbolize .NET primitive - if destType.IsPrimitive then - match symbol with - | Atom (str, _) | Number (str, _) | String (str, _) -> - (TypeDescriptor.GetConverter destType).ConvertFromString str - | Quote (_, _) | Symbols (_, _) -> - failconv "Expected Symbol, Number, or String for conversion to .NET primitive." (Some symbol) - - // desymbolize string - elif destType = typeof then - match symbol with - | Atom (str, _) -> - if Symbol.isExplicit str - then str.Substring (1, str.Length - 2) :> obj - else str :> obj - | Number (str, _) -> - str :> obj - | String (str, _) -> - if printing - then Symbol.OpenStringStr + Symbol.distillate str + Symbol.CloseStringStr :> obj - else str :> obj - | Quote (_, _) | Symbols (_, _) -> - failconv "Expected Symbol, Number, or String for conversion to string." (Some symbol) - - // desymbolize Symbol (no tranformation) - elif destType = typeof then - symbol :> obj - - // desymbolize other... - else - - match destType.TryGetCustomTypeConverter () with - | Some typeConverter -> - - // desymbolize user-defined type - if typeConverter.CanConvertFrom typeof - then typeConverter.ConvertFrom symbol - else failconv ("Expected ability to convert from Symbol for custom type converter '" + getTypeName typeConverter + "'.") (Some symbol) - - | None -> - - // desymbolize DesignerProperty - if destType = typeof then - match (designTypeOpt, symbol) with - | (Some ty, valueSymbol) -> - let value = fromSymbol ty valueSymbol - let property = { DesignerType = ty; DesignerValue = value } - property :> obj - | (None, Symbols ([String (aqTypeName, _); valueSymbol], _)) -> - let ty = Type.GetType aqTypeName - let value = fromSymbol ty valueSymbol - let property = { DesignerType = ty; DesignerValue = value } - property :> obj - | _ -> - failconv "Expected Symbols containing an assembly-qualified type name String and a symbol value." (Some symbol) - - // desymbolize array - elif destType.IsArray then - match symbol with - | Symbols (symbols, _) -> - let elements = List.map (fromSymbol (destType.GetElementType ())) symbols - Reflection.objsToArray destType elements - | Atom (_, _) | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Symbols for conversion to array." (Some symbol) - - // desymbolize unit - elif destType = typeof then - match symbol with - | Symbols ([], _) -> () :> obj - | _ -> failconv "Expected empty Symbols for conversion to unit." (Some symbol) - - // desymbolize list - elif destType.Name = typedefof<_ list>.Name then - match symbol with - | Symbols (symbols, _) -> - let gargs = destType.GetGenericArguments () - let elementType = gargs.[0] - let elements = List.map (fromSymbol elementType) symbols - Reflection.objsToList destType elements - | Atom (_, _) | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Symbols for conversion to list." (Some symbol) - - // desymbolize Set - elif destType.Name = typedefof<_ Set>.Name then - match symbol with - | Symbols (symbols, _) -> - let gargs = destType.GetGenericArguments () - let elementType = gargs.[0] - let elements = List.map (fromSymbol elementType) symbols - Reflection.objsToSet destType elements - | Atom (_, _) | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Symbols for conversion to Set." (Some symbol) - - // desymbolize Map - elif destType.Name = typedefof>.Name then - match symbol with - | Symbols (symbols, _) -> - let gargs = destType.GetGenericArguments () - match gargs with - | [|fstType; sndType|] -> - let pairType = typedefof>.MakeGenericType [|fstType; sndType|] - let pairs = List.map (fromSymbol pairType) symbols - Reflection.pairsToMap destType pairs - | _ -> failwithumf () - | Atom (_, _) | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Symbols for conversion to Map." (Some symbol) - - // desymbolize SymbolicCompression - elif destType.Name = typedefof>.Name then - match symbol with - | Symbols (symbols, _) -> - match symbols with - | (Atom (symbolHead, _)) :: _ -> - let gargs = destType.GetGenericArguments () - let aType = gargs.[0] - let aCases = FSharpType.GetUnionCases aType - match Array.tryFind (fun (unionCase : UnionCaseInfo) -> unionCase.Name = symbolHead) aCases with - | Some aCase -> - let a = fromSymbol aCase.DeclaringType symbol - let compressionUnion = (FSharpType.GetUnionCases destType).[0] - FSharpValue.MakeUnion (compressionUnion, [|a|]) - | None -> - let bType = gargs.[1] - let b = fromSymbol bType symbol - let compressionUnion = (FSharpType.GetUnionCases destType).[1] - FSharpValue.MakeUnion (compressionUnion, [|b|]) - | _ -> failconv "Expected Atom value for SymbolicCompression union name." (Some symbol) - | Atom (_, _) | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Symbols for conversion to SymbolicCompression." (Some symbol) - - // desymbolize Tuple - elif FSharpType.IsTuple destType then - match symbol with - | Symbols (symbols, _) -> - let elementTypes = FSharpType.GetTupleElements destType - let elements = symbols |> Array.ofList |> Array.mapi (fun i elementSymbol -> fromSymbol elementTypes.[i] elementSymbol) - let elements = padWithDefaults' elementTypes elements - FSharpValue.MakeTuple (elements, destType) - | Atom (_, _) | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Symbols for conversion to Tuple." (Some symbol) - - // desymbolize Record - elif FSharpType.IsRecord destType then - match symbol with - | Symbols (symbols, _) -> - if destType.IsDefined (typeof, true) then - let fieldInfos = FSharpType.GetRecordFields destType - if List.forall (function Symbols ([Atom _; _], _) -> true | _ -> false) symbols then - let fieldMap = - symbols |> - List.map (function Symbols ([Atom (fieldName, _); fieldSymbol], _) -> (fieldName, fieldSymbol) | _ -> failwithumf ()) |> - Map.ofList - let fields = - Array.map - (fun (info : PropertyInfo) -> - match Map.tryFind info.Name fieldMap with - | Some fieldSymbol -> fromSymbol info.PropertyType fieldSymbol - | None -> info.PropertyType.GetDefaultValue ()) - fieldInfos - FSharpValue.MakeRecord (destType, fields) - else failconv "Expected Symbols in pairs for expanded Record" (Some symbol) - else - let fieldInfos = FSharpType.GetRecordFields destType - let fields = symbols |> Array.ofList |> Array.mapi (fun i fieldSymbol -> fromSymbol fieldInfos.[i].PropertyType fieldSymbol) - let fields = padWithDefaults fieldInfos fields - FSharpValue.MakeRecord (destType, fields) - | Atom (_, _) | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Symbols for conversion to unexpanded Record." (Some symbol) - - // desymbolize Union - elif FSharpType.IsUnion destType && destType <> typeof then - let unionCases = FSharpType.GetUnionCases destType - match symbol with - | Atom (unionName, _) -> - match Array.tryFind (fun (unionCase : UnionCaseInfo) -> unionCase.Name = unionName) unionCases with - | Some unionCase -> FSharpValue.MakeUnion (unionCase, [||]) - | None -> - let unionNames = unionCases |> Array.map (fun unionCase -> unionCase.Name) |> String.concat " | " - failconv ("Expected one of the following Atom values for Union name: '" + unionNames + "'.") (Some symbol) - | Symbols (symbols, _) -> - match symbols with - | (Atom (symbolHead, _)) :: symbolTail -> - let unionName = symbolHead - match Array.tryFind (fun (unionCase : UnionCaseInfo) -> unionCase.Name = unionName) unionCases with - | Some unionCase -> - let unionFieldInfos = unionCase.GetFields () - let unionValues = symbolTail |> Array.ofList |> Array.mapi (fun i unionSymbol -> fromSymbol unionFieldInfos.[i].PropertyType unionSymbol) - let unionValues = padWithDefaults unionFieldInfos unionValues - FSharpValue.MakeUnion (unionCase, unionValues) - | None -> - let unionNames = unionCases |> Array.map (fun unionCase -> unionCase.Name) |> String.concat " | " - failconv ("Expected one of the following Atom values for Union name: '" + unionNames + "'.") (Some symbol) - | (Number (_, _) | String (_, _) | Quote (_, _) | Symbols (_, _)) :: _ -> - failconv "Expected Atom value for Union name." (Some symbol) - | [] -> - failconv "Expected Atom value for Union name." (Some symbol) - | Number (_, _) | String (_, _) | Quote (_, _) -> - failconv "Expected Atom or Symbols value for conversion to Union." (Some symbol) - - // desymbolize vanilla .NET type - else - match symbol with - | Atom (str, _) | Number (str, _) | String (str, _) -> - (TypeDescriptor.GetConverter destType).ConvertFromString str - | Quote (_, _) | Symbols (_, _) -> - failconv ("Expected Atom, Number, or String value for conversion to vanilla .NET type '" + destType.Name + "'.") (Some symbol) - - let fromString (destType : Type) (source : string) = - let symbol = Symbol.fromString source - fromSymbol destType symbol - - override this.CanConvertTo (_, destType) = - destType = typeof || - destType = typeof || - destType = pointType - - override this.ConvertTo (_, _, source, destType) = - if destType = typeof then - match source with - | null -> - if FSharpType.IsUnion pointType - then (FSharpType.GetUnionCases pointType).[0].Name :> obj - // here we are totally fucked because PropertyGrid passes typeof to the converter's ctor and we - // have no information about what the fuck to do... - else source - | _ -> toString pointType source :> obj - elif destType = typeof then toSymbol pointType source :> obj - elif destType = pointType then source - else failconv "Invalid SymbolicConverter conversion to source." None - - override this.CanConvertFrom (_, sourceType) = - sourceType = typeof || - sourceType = typeof || - sourceType = pointType - - override this.ConvertFrom (_, _, source) = - match source with - | null -> source - | _ -> - let sourceType = source.GetType () - if sourceType <> pointType then - match source with - | :? string as sourceStr -> fromString pointType sourceStr - | :? Symbol as sourceSymbol -> fromSymbol pointType sourceSymbol - | _ -> failconv "Invalid SymbolicConverter conversion from string." None - else source - - new (pointType : Type) = SymbolicConverter (false, None, pointType) \ No newline at end of file diff --git a/Prime/Prime/SymbolicOperators.fs b/Prime/Prime/SymbolicOperators.fs deleted file mode 100644 index 56c31f16fe..0000000000 --- a/Prime/Prime/SymbolicOperators.fs +++ /dev/null @@ -1,50 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open Prime - -[] -module SymbolicOperators = - - /// Convert a value to a symbol. - let valueToSymbol<'a> (value : 'a) = - let ty = if isNull (value :> obj) then typeof<'a> else getType value - let converter = SymbolicConverter (true, None, ty) - converter.ConvertTo (value, typeof) :?> Symbol - - /// Convert a symbol to a value. - let symbolToValue<'a> (symbol : Symbol) : 'a = - let converter = SymbolicConverter (false, None, typeof<'a>) - converter.ConvertFrom symbol :?> 'a - - /// Uses a symbolic converter to convert a value to a string. - let scstring<'a> (value : 'a) = - let ty = if isNull (value :> obj) then typeof<'a> else getType value - let converter = SymbolicConverter (true, None, ty) - converter.ConvertToString value - - /// Uses a symbolic converter to convert a string to a value. - let scvalue<'a> (str : string) : 'a = - let converter = SymbolicConverter (false, None, typeof<'a>) - converter.ConvertFromString str :?> 'a - - /// Get the default value of type 'a taking into account DefaultValue decorations. - let scdefaultof<'a> () : 'a = - let defaultPropertyType = typeof<'a> - let defaultValueAttributeOpt = - defaultPropertyType.GetCustomAttributes (typeof, true) |> - Array.map (fun attr -> attr :?> DefaultValueAttribute) |> - Array.tryHead - match defaultValueAttributeOpt with - | Some defaultValueAttribute -> - match defaultValueAttribute.DefaultValue with - | :? 'a as defaultValue -> defaultValue - | _ as defaultValue -> - let defaultValueType = defaultValue.GetType () - let converter = SymbolicConverter (false, None, defaultValueType) - if converter.CanConvertFrom defaultPropertyType - then converter.ConvertFrom defaultValue :?> 'a - else failwith ("Cannot convert '" + scstring defaultValue + "' to type '" + defaultPropertyType.Name + "'.") - | None -> Unchecked.defaultof<'a> diff --git a/Prime/Prime/TExpr.fs b/Prime/Prime/TExpr.fs deleted file mode 100644 index 8fa9edec1a..0000000000 --- a/Prime/Prime/TExpr.fs +++ /dev/null @@ -1,74 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System - -type [] TConfig = - | BasedOnBuild - | Functional - | Imperative - -module TConfig = - - let isFunctional config = - match config with - | BasedOnBuild -> -#if DEBUG - true -#else - false -#endif - | Functional -> true - | Imperative -> false - -type TExpr<'a, 'env> = - 'env -> struct ('a * 'env) - -type TExprBuilder<'env> () = - - member inline this.Bind (expr : TExpr<'a, 'env>, lift : 'a -> TExpr<'b, 'env>) : TExpr<'b, 'env> = - fun env -> - let struct (result, env') = expr env - let expr' = lift result - expr' env' - - member inline this.Return (value : 'a) : TExpr<'a, 'env> = - fun expr -> - struct (value, expr) - - member inline this.ReturnFrom (value : 'a) = - value - - member this.Zero () = - this.Return () - - member this.Combine (l, r) = - this.Bind (l, fun () -> r) - - member this.TryWith (body : TExpr<'a, 'expr>, handler : exn -> TExpr<'a, 'expr>) : TExpr<'a, 'expr> = - fun env -> - try body env - with exn -> handler exn env - - member this.TryFinally (body : TExpr<'a, 'expr>, compensation) : TExpr<'a,'expr> = - fun env -> - try body env - finally compensation() - - member this.Using (res : #IDisposable, body) = - this.TryFinally (body res, fun () -> - match res with null -> () | disp -> disp.Dispose()) - - member this.Delay f = - this.Bind (this.Return (), f) - - member this.While (guard, body) = - if not (guard ()) - then this.Zero () - else this.Bind (body, fun () -> this.While (guard, body)) - - member this.For (seq : _ seq, body) = - this.Using (seq.GetEnumerator (), fun enr -> - this.While (enr.MoveNext, this.Delay (fun () -> - body enr.Current))) \ No newline at end of file diff --git a/Prime/Prime/TList.fs b/Prime/Prime/TList.fs deleted file mode 100644 index 1b56238904..0000000000 --- a/Prime/Prime/TList.fs +++ /dev/null @@ -1,250 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic - -[] -module TListModule = - - type [] private 'a Log = - | Add of 'a - | Remove of 'a - | Set of int * 'a - | Clear - - type [] 'a TList = - private - { mutable TListOpt : 'a TList - TConfig : TConfig - ImpList : 'a List - ImpListOrigin : 'a List - Logs : 'a Log list - LogsLength : int } - - static member (>>.) (list : 'a2 TList, builder : TExpr) = - snd' (builder list) - - static member (.>>) (list : 'a2 TList, builder : TExpr<'a2, 'a2 TList>) = - fst' (builder list) - - static member (.>>.) (list : 'a2 TList, builder : TExpr<'a2, 'a2 TList>) = - builder list - - let tlist<'a> = TExprBuilder<'a TList> () - - [] - module TList = - - let private commit list = - let oldList = list - let impListOrigin = List<'a> list.ImpListOrigin - List.foldBack (fun log () -> - match log with - | Add value -> impListOrigin.Add value - | Remove value -> impListOrigin.Remove value |> ignore - | Set (index, value) -> impListOrigin.[index] <- value - | Clear -> impListOrigin.Clear ()) - list.Logs () - let impList = List<'a> impListOrigin - let list = { list with ImpList = impList; ImpListOrigin = impListOrigin; Logs = []; LogsLength = 0 } - oldList.TListOpt <- Unchecked.defaultof<'a TList> - list.TListOpt <- list - list - - let private compress list = - let oldList = list - let impListOrigin = List<'a> list.ImpList - let list = { list with ImpListOrigin = impListOrigin; Logs = []; LogsLength = 0 } - oldList.TListOpt <- Unchecked.defaultof<'a TList> - list.TListOpt <- list - list - - let private validate2 list = - match box list.TListOpt with - | null -> commit list - | target -> - match obj.ReferenceEquals (target, list) with - | true -> - if list.LogsLength > list.ImpList.Count - then compress list - else list - | false -> commit list - - let private update updater list = - let oldList = list - let list = validate2 list - let list = updater list - oldList.TListOpt <- Unchecked.defaultof<'a TList> - list.TListOpt <- list - list - - let private validate list = - if TConfig.isFunctional list.TConfig - then validate2 list - else list - - let makeFromSeq config (items : 'a seq) = - if TConfig.isFunctional config then - let impList = List<'a> items - let impListOrigin = List<'a> impList - let list = - { TListOpt = Unchecked.defaultof<'a TList> - TConfig = config - ImpList = impList - ImpListOrigin = impListOrigin - Logs = [] - LogsLength = 0 } - list.TListOpt <- list - list - else - { TListOpt = Unchecked.defaultof<'a TList> - TConfig = config - ImpList = List<'a> items - ImpListOrigin = List<'a> () - Logs = [] - LogsLength = 0 } - - let makeFromArray config (items : 'a array) = - makeFromSeq config items - - let makeEmpty<'a> config = - makeFromSeq config (List<'a> ()) - - let getConfig list = - struct (list.TConfig, list) - - let get index list = - let list = validate list - struct (list.ImpList.[index], list) - - let set index value list = - if TConfig.isFunctional list.TConfig then - update (fun list -> - let list = { list with Logs = Set (index, value) :: list.Logs; LogsLength = list.LogsLength + 1 } - list.ImpList.[index] <- value - list) - list - else list.ImpList.[index] <- value; list - - let add value list = - if TConfig.isFunctional list.TConfig then - update (fun list -> - let list = { list with Logs = Add value :: list.Logs; LogsLength = list.LogsLength + 1 } - list.ImpList.Add value |> ignore - list) - list - else list.ImpList.Add value |> ignore; list - - let remove value list = - if TConfig.isFunctional list.TConfig then - update (fun list -> - let list = { list with Logs = Remove value :: list.Logs; LogsLength = list.LogsLength + 1 } - list.ImpList.Remove value |> ignore - list) - list - else list.ImpList.Remove value |> ignore; list - - let clear list = - if TConfig.isFunctional list.TConfig then - update (fun list -> - let list = { list with Logs = Clear :: list.Logs; LogsLength = list.LogsLength + 1 } - list.ImpList.Clear () - list) - list - else list.ImpList.Clear (); list - - let isEmpty list = - let list = validate list - struct (list.ImpList.Count = 0, list) - - let notEmpty list = - let list = validate list - mapFst' not (isEmpty list) - - /// Get the length of the list (constant-time, obviously). - let length list = - let list = validate list - struct (list.ImpList.Count, list) - - /// Check that a value is contain in the list. - let contains value list = - let list = validate list - struct (list.ImpList.Contains value, list) - - /// Convert a TList to an array. Note that entire list is iterated eagerly since the underlying .NET List could - /// otherwise opaquely change during iteration. - let toArray list = - let list = validate list - struct (Array.ofSeq list.ImpList, list) - - /// Convert a TList to a seq. Note that entire list is iterated eagerly since the underlying .NET List could - /// otherwise opaquely change during iteration. - let toSeq list = - let struct (arr, list) = toArray list - struct (Seq.ofArray arr, list) - - let map (mapper : 'a -> 'b) (list : 'a TList) = - let list = validate list - let seqMapped = Seq.map mapper list.ImpList - let listMapped = makeFromSeq list.TConfig seqMapped - struct (listMapped, list) - - let filter pred list = - let list = validate list - let seqFiltered = Seq.filter pred list.ImpList - let listFiltered = makeFromSeq list.TConfig seqFiltered - struct (listFiltered, list) - - let rev list = - let list = validate list - let seqReversed = Seq.rev list.ImpList - let listReversed = makeFromSeq list.TConfig seqReversed - struct (listReversed, list) - - let sortWith comparison list = - let list = validate list - let seqSorted = Seq.sortWith comparison list.ImpList - let listSorted = makeFromSeq list.TConfig seqSorted - struct (listSorted, list) - - let sortBy by list = - let list = validate list - let seqSorted = Seq.sortBy by list.ImpList - let listSorted = makeFromSeq list.TConfig seqSorted - struct (listSorted, list) - - let sort list = - let list = validate list - let seqSorted = Seq.sort list.ImpList - let listSorted = makeFromSeq list.TConfig seqSorted - struct (listSorted, list) - - let fold folder state list = - let struct (seq, list) = toSeq list - let folded = Seq.fold folder state seq - struct (folded, list) - - let definitize list = - let listMapped = filter Option.isSome list |> fst' - map Option.get listMapped - - let makeFromLists config lists = - // OPTIMIZATION: elides building of avoidable transactions. - let listsAsSeq = toSeq lists |> fst' - let tempList = List<'a> () - for list in listsAsSeq do tempList.AddRange (toSeq list |> fst') - makeFromSeq config tempList - - /// Add all the given values to the list. - let addMany (values : 'a seq) list = - let list = validate list - let lists = add list (makeFromArray list.TConfig [|makeFromSeq list.TConfig values|]) - makeFromLists list.TConfig lists - - /// Remove all the given values from the list. - let removeMany values list = - Seq.fold (flip remove) list values - -type 'a TList = 'a TListModule.TList \ No newline at end of file diff --git a/Prime/Prime/TMap.fs b/Prime/Prime/TMap.fs deleted file mode 100644 index 41679756dd..0000000000 --- a/Prime/Prime/TMap.fs +++ /dev/null @@ -1,206 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic - -[] -module TMapModule = - - type private Log<'k, 'v when 'k : equality> = - | Add of 'k * 'v - | Remove of 'k - | Clear - - type [] TMap<'k, 'v when 'k : equality> = - private - { mutable TMapOpt : TMap<'k, 'v> - TConfig : TConfig - Dict : Dictionary<'k, 'v> - DictOrigin : Dictionary<'k, 'v> - Logs : Log<'k, 'v> list - LogsLength : int } - - static member (>>.) (map : TMap<'k2, 'v2>, builder : TExpr>) = - snd' (builder map) - - static member (.>>) (map : TMap<'k2, 'v2>, builder : TExpr<'v2, TMap<'k2, 'v2>>) = - fst' (builder map) - - static member (.>>.) (map : TMap<'k2, 'v2>, builder : TExpr<'v2, TMap<'k2, 'v2>>) = - builder map - - let tmap<'k, 'v when 'k : equality> = TExprBuilder> () - - [] - module TMap = - - let private commit map = - let oldMap = map - let dictOrigin = Dictionary<'k, 'v> (map.DictOrigin, HashIdentity.Structural) - List.foldBack (fun log () -> - match log with - | Add (key, value) -> dictOrigin.ForceAdd (key, value) - | Remove key -> dictOrigin.Remove key |> ignore - | Clear -> dictOrigin.Clear ()) - map.Logs () - let dict = Dictionary<'k, 'v> (dictOrigin, HashIdentity.Structural) - let map = { map with Dict = dict; DictOrigin = dictOrigin; Logs = []; LogsLength = 0 } - oldMap.TMapOpt <- Unchecked.defaultof> - map.TMapOpt <- map - map - - let private compress map = - let oldMap = map - let dictOrigin = Dictionary<'k, 'v> (map.Dict, HashIdentity.Structural) - let map = { map with DictOrigin = dictOrigin; Logs = []; LogsLength = 0 } - oldMap.TMapOpt <- Unchecked.defaultof> - map.TMapOpt <- map - map - - let private validate2 map = - match box map.TMapOpt with - | null -> commit map - | target -> - match obj.ReferenceEquals (target, map) with - | true -> if map.LogsLength > map.Dict.Count then compress map else map - | false -> commit map - - let private update updater map = - let oldMap = map - let map = validate2 map - let map = updater map - oldMap.TMapOpt <- Unchecked.defaultof> - map.TMapOpt <- map - map - - let private validate map = - if TConfig.isFunctional map.TConfig - then validate2 map - else map - - let makeFromSeq<'k, 'v when 'k : equality> config (entries : ('k * 'v) seq) = - if TConfig.isFunctional config then - let dict = dictPlus entries - let dictOrigin = Dictionary (dict, HashIdentity.Structural) - let map = - { TMapOpt = Unchecked.defaultof> - TConfig = config - Dict = dict - DictOrigin = dictOrigin - Logs = [] - LogsLength = 0 } - map.TMapOpt <- map - map - else - { TMapOpt = Unchecked.defaultof> - TConfig = config - Dict = dictPlus entries - DictOrigin = Dictionary HashIdentity.Structural - Logs = [] - LogsLength = 0 } - - let makeEmpty<'k, 'v when 'k : equality> config = - makeFromSeq<'k, 'v> config Seq.empty - - let getConfig map = - struct (map.TConfig, map) - - let add key value map = - if TConfig.isFunctional map.TConfig then - update (fun map -> - let map = { map with Logs = Add (key, value) :: map.Logs; LogsLength = map.LogsLength + 1 } - map.Dict.ForceAdd (key, value) - map) - map - else map.Dict.ForceAdd (key, value); map - - let remove key map = - if TConfig.isFunctional map.TConfig then - update (fun map -> - let map = { map with Logs = Remove key :: map.Logs; LogsLength = map.LogsLength + 1 } - map.Dict.Remove key |> ignore - map) - map - else map.Dict.Remove key |> ignore; map - - let clear map = - if TConfig.isFunctional map.TConfig then - update (fun map -> - let map = { map with Logs = Clear :: map.Logs; LogsLength = map.LogsLength + 1 } - map.Dict.Clear () - map) - map - else map.Dict.Clear (); map - - let isEmpty map = - let map = validate map - struct (map.Dict.Count = 0, map) - - let notEmpty map = - mapFst' not (isEmpty map) - - /// Get the length of the map (constant-time, obviously). - let length map = - let map = validate map - struct (map.Dict.Count, map) - - let tryFindFast key map = - let map = validate map - match map.Dict.TryGetValue key with - | (true, value) -> struct (FOption.some value, map) - | (false, _) -> struct (FOption.none (), map) - - let tryFind key map = - let map = validate map - match map.Dict.TryGetValue key with - | (true, value) -> struct (Some value, map) - | (false, _) -> struct (None, map) - - let find key map = - let map = validate map - struct (map.Dict.[key], map) - - let containsKey key map = - match tryFind key map with - | struct (Some _, map) -> struct (true, map) - | struct (None, map) -> struct (false, map) - - /// Add all the given entries to the map. - let addMany entries map = - Seq.fold (flip (uncurry add)) map entries - - /// Remove all values with the given keys from the map. - let removeMany keys map = - Seq.fold (flip remove) map keys - - /// Convert a TMap to a seq. Note that entire map is iterated eagerly since the underlying - /// Dictionary could otherwise opaquely change during iteration. - let toSeq map = - let map = validate map - let seq = - map.Dict |> - Seq.map (fun kvp -> (kvp.Key, kvp.Value)) |> - Array.ofSeq :> - seq<'k * 'v> - struct (seq, map) - - let fold folder state map = - let struct (seq, map) = toSeq map - let result = Seq.fold (folder >> uncurry) state seq - struct (result, map) - - let map mapper map = - fold - (fun map key value -> add key (mapper value) map) - (makeEmpty map.TConfig) - map - - let filter pred map = - fold - (fun state k v -> if pred k v then add k v state else state) - (makeEmpty map.TConfig) - map - -type TMap<'k, 'v when 'k : equality> = TMapModule.TMap<'k, 'v> \ No newline at end of file diff --git a/Prime/Prime/TSet.fs b/Prime/Prime/TSet.fs deleted file mode 100644 index 80d8e88607..0000000000 --- a/Prime/Prime/TSet.fs +++ /dev/null @@ -1,185 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections.Generic - -[] -module TSetModule = - - type private Log<'a when 'a : equality> = - | Add of 'a - | Remove of 'a - | Clear - - type [] TSet<'a when 'a : equality> = - private - { mutable TSetOpt : 'a TSet - TConfig : TConfig - HashSet : 'a HashSet - HashSetOrigin : 'a HashSet - Logs : 'a Log list - LogsLength : int } - - static member (>>.) (set : 'a2 TSet, builder : TExpr) = - snd' (builder set) - - static member (.>>) (set : 'a2 TSet, builder : TExpr<'a2, 'a2 TSet>) = - fst' (builder set) - - static member (.>>.) (set : 'a2 TSet, builder : TExpr<'a2, 'a2 TSet>) = - builder set - - let tset<'a when 'a : equality> = TExprBuilder<'a TSet> () - - [] - module TSet = - - let private commit set = - let oldSet = set - let hashSetOrigin = HashSet<'a> (set.HashSetOrigin, HashIdentity.Structural) - List.foldBack (fun log () -> - match log with - | Add value -> hashSetOrigin.TryAdd value |> ignore - | Remove value -> hashSetOrigin.Remove value |> ignore - | Clear -> hashSetOrigin.Clear ()) - set.Logs () - let hashSet = HashSet<'a> (hashSetOrigin, HashIdentity.Structural) - let set = { set with HashSet = hashSet; HashSetOrigin = hashSetOrigin; Logs = []; LogsLength = 0 } - oldSet.TSetOpt <- Unchecked.defaultof<'a TSet> - set.TSetOpt <- set - set - - let private compress set = - let oldSet = set - let hashSetOrigin = HashSet<'a> (set.HashSet, HashIdentity.Structural) - let set = { set with HashSetOrigin = hashSetOrigin; Logs = []; LogsLength = 0 } - oldSet.TSetOpt <- Unchecked.defaultof<'a TSet> - set.TSetOpt <- set - set - - let private validate2 set = - match box set.TSetOpt with - | null -> commit set - | target -> - match obj.ReferenceEquals (target, set) with - | true -> if set.LogsLength > set.HashSet.Count then compress set else set - | false -> commit set - - let private update updater set = - let oldSet = set - let set = validate2 set - let set = updater set - oldSet.TSetOpt <- Unchecked.defaultof<'a TSet> - set.TSetOpt <- set - set - - let private validate set = - if TConfig.isFunctional set.TConfig - then validate2 set - else set - - let makeFromSeq<'a when 'a : equality> config (items : 'a seq) = - if TConfig.isFunctional config then - let hashSet = hashSetPlus items - let hashSetOrigin = HashSet<'a> (hashSet, HashIdentity.Structural) - let set = - { TSetOpt = Unchecked.defaultof<'a TSet> - TConfig = config - HashSet = hashSet - HashSetOrigin = hashSetOrigin - Logs = [] - LogsLength = 0 } - set.TSetOpt <- set - set - else - { TSetOpt = Unchecked.defaultof<'a TSet> - TConfig = config - HashSet = hashSetPlus items - HashSetOrigin = HashSet<'a> HashIdentity.Structural - Logs = [] - LogsLength = 0 } - - let makeEmpty<'a when 'a : equality> config = - makeFromSeq<'a> config Seq.empty - - let getConfig set = - struct (set.TConfig, set) - - let add value set = - if TConfig.isFunctional set.TConfig then - update (fun set -> - let set = { set with Logs = Add value :: set.Logs; LogsLength = set.LogsLength + 1 } - set.HashSet.TryAdd value |> ignore - set) - set - else set.HashSet.TryAdd value |> ignore; set - - let remove value set = - if TConfig.isFunctional set.TConfig then - update (fun set -> - let set = { set with Logs = Remove value :: set.Logs; LogsLength = set.LogsLength + 1 } - set.HashSet.Remove value |> ignore - set) - set - else set.HashSet.Remove value |> ignore; set - - let clear set = - if TConfig.isFunctional set.TConfig then - update (fun set -> - let set = { set with Logs = Clear :: set.Logs; LogsLength = set.LogsLength + 1 } - set.HashSet.Clear () - set) - set - else set.HashSet.Clear (); set - - let isEmpty set = - let set = validate set - struct (set.HashSet.Count = 0, set) - - let notEmpty set = - mapFst' not (isEmpty set) - - /// Get the length of the set (constant-time, obviously). - let length set = - let set = validate set - (set.HashSet.Count, set) - - let contains value set = - let set = validate set - struct (set.HashSet.Contains value, set) - - /// Add all the given values to the set. - let addMany values set = - Seq.fold (flip add) set values - - /// Remove all the given values from the set. - let removeMany values set = - Seq.fold (flip remove) set values - - /// Convert a TSet to a seq. Note that entire set is iterated eagerly since the underlying HashMap could - /// otherwise opaquely change during iteration. - let toSeq set = - let set = validate set - let seq = set.HashSet |> Array.ofSeq :> 'a seq - struct (seq, set) - - let fold folder state set = - let struct (seq, set) = toSeq set - let result = Seq.fold folder state seq - struct (result, set) - - let map mapper set = - fold - (fun set value -> add (mapper value) set) - (makeEmpty set.TConfig) - set - - let filter pred set = - fold - (fun set value -> if pred value then add value set else set) - (makeEmpty set.TConfig) - set - -type TSet<'a when 'a : equality> = TSetModule.TSet<'a> \ No newline at end of file diff --git a/Prime/Prime/Triple.fs b/Prime/Prime/Triple.fs deleted file mode 100644 index bb99e9cbbe..0000000000 --- a/Prime/Prime/Triple.fs +++ /dev/null @@ -1,89 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime - -[] -module TripleOperators = - - /// The first item in a triple. - let inline a__ triple = - match triple with - | (a, _, _) -> a - - /// The second item in a triple. - let inline _b_ triple = - match triple with - | (_, b, _) -> b - - /// The third item in a triple. - let inline __c triple = - match triple with - | (_, _, c) -> c - - /// The first and second items in a triple. - let inline ab_ triple = - match triple with - | (a, b, _) -> (a, b) - - /// The first and third items in a triple. - let inline a_c triple = - match triple with - | (a, _, c) -> (a, c) - - /// The second and third items in a triple. - let inline _bc triple = - match triple with - | (_, b, c) -> (b, c) - -[] -module Triple = - - /// The first item in a triple. - let fst = a__ - - /// The second item in a triple. - let snd = _b_ - - /// The third item in a triple. - let thd = __c - - /// Prepend an item to a pair to build a triple. - let inline prepend a (b, c) = - (a, b, c) - - /// Insert an item in a pair to build a triple. - let inline insert b (a, c) = - (a, b, c) - - /// Append an item to a pair to build a triple. - let inline append c (a, b) = - (a, b, c) - - /// Replace triple member a. - let inline withA a (_, b, c) = - (a, b, c) - - /// Replace triple member b. - let inline withB b (a, _, c) = - (a, b, c) - - /// Replace triple member c. - let inline withC c (a, b, _) = - (a, b, c) - - /// Map over triple member a. - let inline mapA mapper (a, b, c) = - (mapper a, b, c) - - /// Map over triple member b. - let inline mapB mapper (a, b, c) = - (a, mapper b, c) - - /// Map over triple member c. - let inline mapC mapper (a, b, c) = - (a, b, mapper c) - - /// Make a triple. - let make a b c = - (a, b, c) \ No newline at end of file diff --git a/Prime/Prime/UList.fs b/Prime/Prime/UList.fs deleted file mode 100644 index e7fdc43878..0000000000 --- a/Prime/Prime/UList.fs +++ /dev/null @@ -1,141 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System.Collections -open System.Collections.Generic - -[] -module UListModule = - - type [] 'a UList = - private - { ListRef : 'a TList ref } - - interface 'a IEnumerable with - member this.GetEnumerator () = - let struct (seq, tlist) = TList.toSeq !this.ListRef - this.ListRef := tlist - seq.GetEnumerator () - - interface IEnumerable with - member this.GetEnumerator () = - (this :> 'a IEnumerable).GetEnumerator () :> IEnumerator - - member this.Item index = - let struct (result, tlist) = TList.get index !this.ListRef - this.ListRef := tlist - result - - [] - module UList = - - let makeFromSeq config items = - { ListRef = ref (TList.makeFromSeq config items) } - - let makeFromArray config items = - { ListRef = ref (TList.makeFromArray config items) } - - let makeEmpty<'a> config = - { ListRef = ref (TList.makeEmpty<'a> config) } - - let getConfig list = - let struct (result, tlist) = TList.getConfig !list.ListRef - list.ListRef := tlist - result - - let get (index : int) (list : 'a UList) = - list.[index] - - let set index value list = - { ListRef = ref (TList.set index value !list.ListRef) } - - let add value list = - { ListRef = ref (TList.add value !list.ListRef) } - - let remove value list = - { ListRef = ref (TList.remove value !list.ListRef) } - - let clear list = - { ListRef = ref (TList.clear !list.ListRef) } - - let isEmpty list = - let struct (result, tlist) = TList.isEmpty !list.ListRef - list.ListRef := tlist - result - - let notEmpty list = - not (isEmpty list) - - let length list = - let struct (result, tlist) = TList.length !list.ListRef - list.ListRef := tlist - result - - let contains value list = - let struct (result, tlist) = TList.contains value !list.ListRef - list.ListRef := tlist - result - - let toArray (list : _ UList) = - let struct (arr, tlist) = TList.toArray !list.ListRef - list.ListRef := tlist - arr - - let toSeq (list : _ UList) = - list :> _ seq - - let map mapper list = - let struct (result, tlist) = TList.map mapper !list.ListRef - list.ListRef := tlist - { ListRef = ref result } - - let filter pred list = - let struct (result, tlist) = TList.filter pred !list.ListRef - list.ListRef := tlist - { ListRef = ref result } - - let rev list = - let struct (result, tlist) = TList.rev !list.ListRef - list.ListRef := tlist - { ListRef = ref result } - - let sortWith comparison list = - let struct (result, tlist) = TList.sortWith comparison !list.ListRef - list.ListRef := tlist - { ListRef = ref result } - - let sortBy by list = - let struct (result, tlist) = TList.sortBy by !list.ListRef - list.ListRef := tlist - { ListRef = ref result } - - let sort list = - let struct (result, tlist) = TList.sort !list.ListRef - list.ListRef := tlist - { ListRef = ref result } - - let fold folder state list = - let struct (result, tlist) = TList.fold folder state !list.ListRef - list.ListRef := tlist - result - - let definitize list = - let struct (result, tlist) = TList.definitize !list.ListRef - list.ListRef := tlist - { ListRef = ref result } - - let makeFromLists config lists = - let tlists = !(map (fun (list : 'a UList) -> !list.ListRef) lists).ListRef - let tlist = TList.makeFromLists config tlists - { ListRef = ref tlist } - - /// Add all the given values to the list. - let addMany values list = - { ListRef = ref (TList.addMany values !list.ListRef) } - - /// Remove all the given values from the list. - let removeMany values list = - { ListRef = ref (TList.removeMany values !list.ListRef) } - -type 'a UList = 'a UListModule.UList \ No newline at end of file diff --git a/Prime/Prime/UMap.fs b/Prime/Prime/UMap.fs deleted file mode 100644 index 971f7bbcf6..0000000000 --- a/Prime/Prime/UMap.fs +++ /dev/null @@ -1,100 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections -open System.Collections.Generic - -[] -module UMapModule = - - type [] UMap<'k, 'v when 'k : equality> = - private - { MapRef : TMap<'k, 'v> ref } - - interface IEnumerable<'k * 'v> with - member this.GetEnumerator () = - let struct (seq, tmap) = TMap.toSeq !this.MapRef - this.MapRef := tmap - seq.GetEnumerator () - - interface IEnumerable with - member this.GetEnumerator () = - (this :> IEnumerable<'k * 'v>).GetEnumerator () :> IEnumerator - - [] - module UMap = - - let makeFromSeq<'k, 'v when 'k : equality> config entries = - { MapRef = ref (TMap.makeFromSeq<'k, 'v> config entries) } - - let makeEmpty<'k, 'v when 'k : equality> config = - { MapRef = ref (TMap.makeEmpty<'k, 'v> config) } - - let getConfig map = - let struct (result, tmap) = TMap.getConfig !map.MapRef - map.MapRef := tmap - result - - let add key value map = - { MapRef = ref (TMap.add key value !map.MapRef) } - - let remove key map = - { MapRef = ref (TMap.remove key !map.MapRef) } - - let isEmpty map = - let struct (result, tmap) = TMap.isEmpty !map.MapRef - map.MapRef := tmap - result - - let notEmpty map = - not (isEmpty map) - - let tryFindFast key map = - let struct (valueOpt, tmap) = TMap.tryFindFast key !map.MapRef - map.MapRef := tmap - valueOpt - - let tryFind key map = - let struct (valueOpt, tmap) = TMap.tryFind key !map.MapRef - map.MapRef := tmap - valueOpt - - let find key map = - let struct (item, tmap) = TMap.find key !map.MapRef - map.MapRef := tmap - item - - let containsKey key map = - let struct (result, tmap) = TMap.containsKey key !map.MapRef - map.MapRef := tmap - result - - /// Add all the given entries to the map. - let addMany entries map = - { MapRef = ref (TMap.addMany entries !map.MapRef) } - - /// Remove all values with the given keys from the map. - let removeMany keys map = - { MapRef = ref (TMap.removeMany keys !map.MapRef) } - - let toSeq (map : UMap<_, _>) = - map :> _ seq - - let fold folder state map = - let struct (result, tmap) = TMap.fold folder state !map.MapRef - map.MapRef := tmap - result - - let map mapper map = - let struct (result, tmap) = TMap.map mapper !map.MapRef - map.MapRef := tmap - { MapRef = ref result } - - let filter pred map = - let struct (result, tmap) = TMap.filter pred !map.MapRef - map.MapRef := tmap - { MapRef = ref result } - -type UMap<'k, 'v when 'k : equality> = UMapModule.UMap<'k, 'v> \ No newline at end of file diff --git a/Prime/Prime/USet.fs b/Prime/Prime/USet.fs deleted file mode 100644 index 596b56f288..0000000000 --- a/Prime/Prime/USet.fs +++ /dev/null @@ -1,88 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Collections -open System.Collections.Generic - -[] -module USetModule = - - type [] USet<'a when 'a : equality> = - private - { SetRef : 'a TSet ref } - - interface IEnumerable<'a> with - member this.GetEnumerator () = - let struct (seq, tset) = TSet.toSeq !this.SetRef - this.SetRef := tset - seq.GetEnumerator () - - interface IEnumerable with - member this.GetEnumerator () = - (this :> IEnumerable<'a>).GetEnumerator () :> IEnumerator - - [] - module USet = - - let makeFromSeq<'a when 'a : equality> config items = - { SetRef = ref (TSet.makeFromSeq<'a> config items) } - - let makeEmpty<'a when 'a : equality> config = - { SetRef = ref (TSet.makeEmpty<'a> config) } - - let getConfig set = - let struct (result, tset) = TSet.getConfig !set.SetRef - set.SetRef := tset - result - - let add value set = - { SetRef = ref (TSet.add value !set.SetRef) } - - let remove value set = - { SetRef = ref (TSet.remove value !set.SetRef) } - - let clear set = - { SetRef = ref (TSet.clear !set.SetRef) } - - /// Add all the given values to the set. - let addMany values set = - { SetRef = ref (TSet.addMany values !set.SetRef) } - - /// Remove all the given values from the set. - let removeMany values set = - { SetRef = ref (TSet.removeMany values !set.SetRef) } - - let isEmpty set = - let struct (result, tset) = TSet.isEmpty !set.SetRef - set.SetRef := tset - result - - let notEmpty set = - not (isEmpty set) - - let contains value set = - let struct (result, tset) = TSet.contains value !set.SetRef - set.SetRef := tset - result - - let toSeq (set : _ USet) = - set :> _ seq - - let fold folder state set = - let struct (result, tset) = TSet.fold folder state !set.SetRef - set.SetRef := tset - result - - let map mapper set = - let struct (result, tset) = TSet.map mapper !set.SetRef - set.SetRef := tset - { SetRef = ref result } - - let filter pred set = - let struct (result, tset) = TSet.filter pred !set.SetRef - set.SetRef := tset - { SetRef = ref result } - -type USet<'a when 'a : equality> = USetModule.USet<'a> \ No newline at end of file diff --git a/Prime/Prime/UserState.fs b/Prime/Prime/UserState.fs deleted file mode 100644 index c10d72fca1..0000000000 --- a/Prime/Prime/UserState.fs +++ /dev/null @@ -1,86 +0,0 @@ -namespace Prime -open System -open System.ComponentModel - -[] -module UserStateModule = - - type UserStateConverter () = - inherit TypeConverter () - - override this.CanConvertTo (_, destType) = - destType = typeof || - destType = typeof - - override this.ConvertTo (_, _, source, destType) = - if destType = typeof then - let userState = source :?> UserState - let typeSymbol = Symbol.String (userState.Type.AssemblyQualifiedName, None) - let valueConverter = SymbolicConverter userState.Type - let valueSymbol = valueConverter.ConvertTo (userState.Value, typeof) :?> Symbol - let imperativeConverter = SymbolicConverter typeof - let imperativeSymbol = imperativeConverter.ConvertTo (userState.Imperative, typeof) :?> Symbol - Symbols ([typeSymbol; valueSymbol; imperativeSymbol], None) :> obj - elif destType = typeof then source - else failconv "Invalid UserState conversion to source." None - - override this.CanConvertFrom (_, sourceType) = - sourceType = typeof || - sourceType = typeof - - override this.ConvertFrom (_, _, source) = - match source with - | :? Symbol as symbol -> - match symbol with - | Symbols ([String (typeName, _); valueSymbol; imperativeSymbol], _) -> - let valueType = Type.GetType (typeName, true, false) - let valueConverter = SymbolicConverter valueType - let value = valueConverter.ConvertFrom valueSymbol; - let imperativeConverter = SymbolicConverter typeof - let imperative = imperativeConverter.ConvertFrom imperativeSymbol :?> bool - { Type = valueType; Value = value; Imperative = imperative } :> obj - | _ -> failconv "Invalid UserState conversion from source." (Some symbol) - | :? UserState -> source - | _ -> failconv "Invalid UserState conversion from source." None - - /// User-defined state. - and [)>] UserState = - private - { mutable Type : Type - mutable Value : obj - Imperative : bool } - - [] - module UserState = - - /// Check that the user state is imperative. - let getImperative userState = - userState.Imperative - - /// Get the state. - let get<'a> userState : 'a = - userState.Value :?> 'a - - /// Set the state. - let set<'a> (value : 'a) userState = - if userState.Imperative then - userState.Type <- typeof<'a> - userState.Value <- value - userState - else - { userState with - Type = typeof<'a> - Value = value } - - let update (updater : 'a -> 'b) userState = - let value = get userState - set (updater value) userState - - /// Make UserState. - let make (value : 'a) imperative = - { Type = typeof<'a> - Value = value - Imperative = imperative } - -/// User-defined state. -type UserState = UserStateModule.UserState \ No newline at end of file diff --git a/Prime/Prime/Vsync.fs b/Prime/Prime/Vsync.fs deleted file mode 100644 index e4c5414310..0000000000 --- a/Prime/Prime/Vsync.fs +++ /dev/null @@ -1,231 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open System.Diagnostics -open System.Threading -open System.Threading.Tasks -open Prime - -/// Async extensions. -module Async = - - /// Creates an asynchronous operation that runs 'f' over computation of 'a'. - let Map f a = - async - { let! b = a - return f b } - -[] -module VsyncModule = - - /// The 'Vsync' (AKA, 'Variable Synchrony') monad. - /// Allows code to run in either an async or synchronous fashion to aid in debugging. - /// NOTE: to reference how all this stuff works in F#, see here - https://msdn.microsoft.com/en-us/library/dd233182.aspx - type [] 'a Vsync = - private - | Sync of (unit -> 'a) - | Async of 'a Async - - [] - module Vsync = - - /// Configures whether to use synchronized processing. - let mutable private SyncOpt = None - - /// Initialize Vsync to use synchronized or asynchronous processing. - let init sync = - match SyncOpt with - | Some _ -> Log.debug "Cannot init Vsync.sync once it's been set. Consider calling init earlier in your program." - | None -> SyncOpt <- Some sync - - /// Query whether Vsync is using synchronized or asynchronous processing. - let isSync () = - match SyncOpt with - | Some sync -> sync - | None -> - Log.debug "Sync not set manually before first invocation; automatically setting to true." - let result = true - SyncOpt <- Some result - result - - let [] private Extract v = - match v with - | Sync _ -> failwithumf () - | Async a -> a - - /// Creates a potentially asynchronous operation that runs computation, and when computation results, runs binder resolution. - let [] Bind v f = - match v with - | Sync a -> f (a ()) - | Async a -> Async (async.Bind (a, f >> Extract)) - - /// Creates a potentially asynchronous operation that returns the result 'a'. - let [] Return a = - if isSync () - then Sync (fun () -> a) - else Async (async.Return a) - - /// Delegates to input computation. - let [] ReturnFrom v = - match v with - | Sync a -> Sync (fun () -> a ()) - | Async a -> Async (async.ReturnFrom a) - - /// Creates a potentially asynchronous computation that runs binder 'f' over resource 'd'. - /// Dispose is executed as this computation yields its result or if the asynchronous computation raises or by cancellation. - let [] Using d f = - if isSync () - then Sync (fun () -> use u = d in match f u with Sync b -> b () | Async _ -> failwithumf ()) - else Async (async.Using (d, f >> Extract)) - - /// Creates a potentially asynchronous computation that runs generator 'f'. - let [] Delay f = - if isSync () - then Sync (fun () -> match f () with Sync a -> a () | _ -> failwithumf ()) - else Async (async.Delay (f >> Extract)) - - /// Creates a potentially asynchronous computation that just returns unit. - let [] Zero () = - if isSync () - then Sync (fun () -> ()) - else Async (async.Zero ()) - - /// Creates a potentially asynchronous computation that first runs computation 'a' and then computation 'b', returning the result of the latter. - let [] Combine a b = - match b with - | Sync b' -> Sync (fun () -> b' ()) - | Async b' -> Async (async.Combine (Extract a, b')) - - /// Creates a potentially asynchronous computation that enumerates the sequence 's', and runs the body 'f' for each item. - let [] For s f = - if isSync () - then Sync (fun () -> Seq.iter (f >> ignore) s) - else Async (async.For (s, f >> Extract)) - - /// Creates a potentially asynchronous computation that runs computation until guard 'g' becomes false. - let [] While g v = - match v with - | Sync a -> Sync (fun () -> while g () do a ()) - | Async a -> Async (async.While (g, a)) - - /// Creates a potentially asynchronous computation that runs computation and returns its result. - /// If an exception happens, then handler 'h' is called and the resulting computation executes instead. - let [] TryWith (v : 'a Vsync) (h : exn -> 'a Vsync) : 'a Vsync = - match v with - | Sync a -> Sync (fun () -> try a () with exn -> match h exn with Sync b -> b () | Async _ -> failwithumf ()) - | Async a -> Async (async.TryWith (a, h >> Extract)) - - /// Creates a potentially asynchronous computation that runs computation. - /// The action compensation 'h' is executed after the computation completes regardless of the outcome. - /// If the computation raises and exception itself, the original exception is discarded and the new exception becomes the overall result. - let [] TryFinally (v : 'a Vsync) (h : unit -> unit) : 'a Vsync = - match v with - | Sync a -> Sync (fun () -> try a () finally h ()) - | Async a -> Async (async.TryFinally (a, h)) - - /// Creates a potentially asynchronous computation that runs the given computation and ignores its results. - let [] Ignore v = - match v with - | Sync a -> Sync (fun () -> a () |> ignore) - | Async a -> Async (Async.Ignore a) - - /// Creates a potentially asynchronous computation that will sleep for the given time. - /// The operation will not block operating system threads for the duration of the wait when running asynchronously. - /// The operation will block operating system thread for the duration of the wait otherwise. - let [] Sleep (t : int) = - if isSync () - then Sync (fun () -> Thread.Sleep t) - else Async (Async.Sleep t) - - /// Runs the potentially asynchronous computation and awaits its result. - let [] RunSynchronously v = - match v with - | Sync a -> a () - | Async a -> Async.RunSynchronously a - - /// Starts the potentially asynchronous computation. - /// Computation is run in the thread pool not awaiting its result when asynchronous. - /// Computation is run in the current thread awaiting its result otherwise. - let [] Start v = - match v with - | Sync a -> a () - | Async a -> Async.Start a - - /// Executes a computation in the thread pool when asynchronous, in the same thread otherwise. - let [] StartAsTask v = - match v with - | Sync a -> Task.Factory.StartNew a - | Async a -> Async.StartAsTask a - - /// Return a potentially asynchronous computation that will wait for the given task to complete and return its result. - let [] AwaitTaskT (t : _ Task) = - if isSync () - then Sync (fun () -> t.Result) - else Async (Async.AwaitTask t) - - /// Return a potentially asynchronous computation that will wait for the given task to complete and return its result. - let [] AwaitTask (t : Task) = - if isSync () - then Sync (fun () -> t.Wait ()) - else Async (Async.AwaitTask t) - - /// Creates a potentially asynchronous computation that executes computation. - /// If this computation completes successfully, then return Choice1Of2 with the returned value. - /// If this computation raises before completion, then return Choice2Of2 with the raised exception. - let [] Catch v = - match v with - | Sync a -> Sync (fun () -> try Choice1Of2 ^ a () with exn -> Choice2Of2 exn) - | Async a -> Async (Async.Catch a) - - /// Creates a potentially asynchronous computation that executes all the given computations - /// Initially queues each as work item using a fork/join pattern when asynchronous. - /// Executes each work item sequentially on the same thread otherwise. - let [] Parallel s = - if isSync () - then Sync (fun () -> Array.ofSeq ^ Seq.map (function Sync a -> a () | Async _ -> failwithumf ()) s) - else Async (Async.Parallel (Seq.map Extract s)) - - /// Creates a potentially asynchronous operation that runs 'f' over computation of 'a'. - let [] Map f v = - match v with - | Sync a -> Sync (fun () -> f (a ())) - | Async a -> Async (Async.Map f a) - -/// The Vsync computation expression builder. -type [] VsyncBuilder () = - - member inline this.Bind (m, f) = Vsync.Bind m f - member inline this.Return a = Vsync.Return a - member inline this.ReturnFrom m = Vsync.ReturnFrom m - member inline this.Using (d, b) = Vsync.Using d b - member inline this.Delay f = Vsync.Delay f - member inline this.Zero () = Vsync.Zero () - member inline this.Combine (a, b) = Vsync.Combine a b - member inline this.For (m, f) = Vsync.For m f - member inline this.While (g, b) = Vsync.While g b - member inline this.TryWith (b, h) = Vsync.TryWith b h - member inline this.TryFinally (b, c) = Vsync.TryFinally b c - static member inline Ignore v = Vsync.Ignore v - static member inline Sleep t = Vsync.Sleep t - static member inline RunSynchronously v = Vsync.RunSynchronously v - static member inline Start v = Vsync.Start v - static member inline StartAsTask v = Vsync.StartAsTask v - static member inline AwaitTaskT (t : _ Task) = Vsync.AwaitTaskT t - static member inline AwaitTask (t : Task) = Vsync.AwaitTask t - static member inline Catch v = Vsync.Catch v - static member inline Parallel s = Vsync.Parallel s - static member inline Map f v = Vsync.Map f v - -[] -module VsyncBuilderModule = - - /// The VsyncBuilder instance. - /// Used like: vsync { return 0 } - let vsync = VsyncBuilder () - -/// The 'Vsync' (AKA, 'Variable Synchrony') monad. -/// Allows code to run in either an async or synchronous fashion to aid in debugging. -/// NOTE: to reference how all this stuff works in F#, see here - https://msdn.microsoft.com/en-us/library/dd233182.aspx -type 'a Vsync = 'a VsyncModule.Vsync \ No newline at end of file diff --git a/Prime/Prime/Xtension.fs b/Prime/Prime/Xtension.fs deleted file mode 100644 index d7d60379f3..0000000000 --- a/Prime/Prime/Xtension.fs +++ /dev/null @@ -1,154 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime -open System -open Prime - -[] -module XtensionModule = - - /// Xtensions are a dynamic, functional, and convenient way to implement both dynamic properties - /// and designer properties. - type [] Xtension = - private - { Properties : PropertyMap - CanDefault : bool - Sealed : bool - Imperative : bool } - - /// Try to get the default value for a given xtension member, returning None when defaulting is disallowed. - static member private tryGetDefaultValue (this : Xtension) propertyName : 'a = - if this.CanDefault then scdefaultof () - else failwith ("Xtension property '" + propertyName + "' does not exist and no default is permitted because CanDefault is false.") - - /// The dynamic look-up operator for an Xtension. - /// Example: - /// let parallax = xtn?Parallax : single - static member (?) (xtension, propertyName) : 'a = - - // check if dynamic member is an existing property - let propertyOpt = UMap.tryFindFast propertyName xtension.Properties - if FOption.isSome propertyOpt then - - // return property directly if the return type matches, otherwise the default value for that type - let property = FOption.get propertyOpt - match property.PropertyValue with - | :? DesignerProperty as dp -> - match dp.DesignerValue with - | :? 'a as propertyValue -> propertyValue - | _ -> failwith ("Xtension property '" + propertyName + "' of type '" + property.PropertyType.Name + "' is not of the expected type '" + typeof<'a>.Name + "'.") - | :? 'a as value -> value - | _ -> failwith ("Xtension property '" + propertyName + "' of type '" + property.PropertyType.Name + "' is not of the expected type '" + typeof<'a>.Name + "'.") - - else - - // presume we're looking for a property that doesn't exist, so try to get the default value - Xtension.tryGetDefaultValue xtension propertyName - - /// The dynamic assignment operator for an Xtension. - /// Example: - /// let xtn = xtn.Position <- Vector2 (4.0, 5.0). - static member (?<-) (xtension, propertyName, value : 'a) = - if typeof<'a> = typeof then failwith "Cannot directly set an Xtension property to a DesignerProperty." - let propertyOpt = UMap.tryFindFast propertyName xtension.Properties - if FOption.isSome propertyOpt then - let mutable property = FOption.get propertyOpt - if xtension.Sealed && property.PropertyType <> typeof<'a> then failwith "Cannot change the type of a sealed Xtension's property." - if xtension.Imperative then - match property.PropertyValue with - | :? DesignerProperty as dp -> dp.DesignerValue <- value :> obj - | _ -> property.PropertyValue <- value :> obj - xtension - else - match property.PropertyValue with - | :? DesignerProperty as dp -> - let property = { property with PropertyValue = { dp with DesignerValue = value }} - let properties = UMap.add propertyName property xtension.Properties - { xtension with Properties = properties } - | _ -> - let property = { property with PropertyValue = value :> obj } - let properties = UMap.add propertyName property xtension.Properties - { xtension with Properties = properties } - else - if xtension.Sealed then failwith "Cannot add property to a sealed Xtension." - let property = { PropertyType = typeof<'a>; PropertyValue = value :> obj } - let properties = UMap.add propertyName property xtension.Properties - { xtension with Properties = properties } - - [] - module Xtension = - - /// The TConfig of Xtension's T/U structures. - let Config = Functional - - /// Make an extension. - let make properties canDefault isSealed imperative = - { Properties = properties - CanDefault = canDefault - Sealed = isSealed - Imperative = imperative } - - /// An Xtension that cannot default, is sealed, and is imperative. - let makeImperative () = make (UMap.makeEmpty Config) false true true - - /// An Xtension that can default, isn't sealed, and isn't imperative. - let makeEmpty () = make (UMap.makeEmpty Config) true false false - - /// An Xtension that cannot default, is sealed, and isn't imperative. - let makeSafe () = make (UMap.makeEmpty Config) false true false - - /// An Xtension that cannot default, isn't sealed, and isn't imperative. - let makeMixed () = make (UMap.makeEmpty Config) false false false - - /// Whether the extension uses mutation. - let getImperative xtension = xtension.Imperative - - /// Try to get a property from an xtension. - let tryGetProperty name xtension = UMap.tryFind name xtension.Properties - - /// Get a property from an xtension. - let getProperty name xtension = UMap.find name xtension.Properties - - /// Set a property on an Xtension. - let trySetProperty name property xtension = - match UMap.tryFind name xtension.Properties with - | Some property' -> - if xtension.Imperative then - let mutable property' = property' // rebind as mutable - property'.PropertyType <- property.PropertyType - property'.PropertyValue <- property.PropertyValue - (true, xtension) - else (true, { xtension with Properties = UMap.add name property xtension.Properties }) - | None -> - if not xtension.Sealed - then (true, { xtension with Properties = UMap.add name property xtension.Properties }) - else (false, xtension) - - /// Set a property on an Xtension. - let setProperty name property xtension = - match trySetProperty name property xtension with - | (true, xtension) -> xtension - | (false, _) -> failwith "Cannot add property to a sealed Xtension." - - /// Attach a property to an Xtension. - let attachProperty name property xtension = { xtension with Properties = UMap.add name property xtension.Properties } - - /// Attach multiple properties to an Xtension. - let attachProperties namesAndProperties xtension = { xtension with Properties = UMap.addMany namesAndProperties xtension.Properties } - - /// Detach a property from an Xtension. - let detachProperty name xtension = { xtension with Properties = UMap.remove name xtension.Properties } - - /// Detach multiple properties from an Xtension. - let detachProperties names xtension = { xtension with Properties = UMap.removeMany names xtension.Properties } - - /// Convert an xtension to a sequence of its entries. - let toSeq xtension = xtension.Properties :> _ seq - - /// Convert an xtension to a sequence of its entries. - let ofSeq seq = attachProperties seq (makeEmpty ()) - -/// Xtensions (and their supporting types) are a dynamic, functional, and convenient way -/// to implement dynamic properties. -type Xtension = XtensionModule.Xtension diff --git a/Prime/Prime/XtensionTests.fs b/Prime/Prime/XtensionTests.fs deleted file mode 100644 index 8a26fc722a..0000000000 --- a/Prime/Prime/XtensionTests.fs +++ /dev/null @@ -1,46 +0,0 @@ -// Prime - A PRIMitivEs code library. -// Copyright (C) Bryan Edds, 2013-2018. - -namespace Prime.Tests -open System -open Xunit -open Prime - -type [] TestXtended = - { Xtension : Xtension } - - static member (?) (this : TestXtended, propertyName) = - Xtension.(?) (this.Xtension, propertyName) - - static member (?<-) (this : TestXtended, propertyName, value) = - let xtension = Xtension.(?<-) (this.Xtension, propertyName, value) - { this with Xtension = xtension } - -module XtensionTests = - - let [] canAddProperty () = - let xtn = Xtension.makeEmpty () - let xtn = xtn?TestProperty <- 5 - let propertyValue = xtn?TestProperty - Assert.Equal (5, propertyValue) - - let [] cantAddPropertyWhenSealed () = - let xtn = Xtension.makeSafe () - Assert.Throws (fun () -> (xtn?TestProperty <- 0) |> ignore) - - let [] cantAccessNonexistentProperty () = - let xtn = Xtension.makeMixed () - let xtn = xtn?TestProperty <- 5 - Assert.Throws (fun () -> xtn?TetProperty |> ignore) - - let [] missingPropertyReturnsDefault () = - let xtn = Xtension.makeEmpty () - let xtn = xtn?TestProperty <- 0 - let propertyValue = xtn?MissingProperty - Assert.Equal (0, propertyValue) - - let [] canAddPropertyViaContainingType () = - let xtd = { Xtension = Xtension.makeEmpty () } - let xtd = xtd?TestProperty <- 5 - let propertyValue = xtd?TestProperty - Assert.Equal (5, propertyValue) \ No newline at end of file diff --git a/Prime/ReadMe.md b/Prime/ReadMe.md deleted file mode 100644 index 5367556e97..0000000000 --- a/Prime/ReadMe.md +++ /dev/null @@ -1,19 +0,0 @@ -The Prime F# Code Library [![License](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/bryanedds/Nu/blob/master/Prime/LICENSE.md) [![NuGet](https://img.shields.io/nuget/v/Nuget.Core.svg)](https://www.nuget.org/packages/Prime) -= - -## Features - -- A metaprogramming system based on symbolic expressions with the **Symbol** and **SymbolicConverter** types. -- A generalized serialization system based on the above and related types. -- A powerful and reusable scripting language, AMSL, with the types in the **Scripting** module. -- A purely functional, publisher-neutral event system with **EventSystem** and related types. -- The functional-reactive **Stream** and **Chain** monads for said event system. -- A purely functional dynamic property system called **Xtension**. -- A purely functional random number generator called **Rand**. -- The incredibly valuable **VSync** monad allowing the same program to be run in parallel or debugged sequentially. -- The fastest-known persistent hash map in F#, **VMap** - over twice as fast as Map, and 1/3 look-up speed of Dictionary! -- Fastest pure functional **UList**, **UMap**, and **USet** collections rivaling the speed of .NET List, Dictionary and HashSet. -- Innovative pure-functional wrappers for arbitrary impure objects, **KeyedCache** and **MutantCache**. -- So many extension primitives I couldn't hope to mention them all! - -Prime is built with clean and modular **Abstract Data Type** programming style as presented here - https://vimeo.com/128464151 \ No newline at end of file diff --git a/Projects/BlazeVector/BlazeVector.fsproj b/Projects/BlazeVector/BlazeVector.fsproj index 250a0e941f..f6252b5c09 100644 --- a/Projects/BlazeVector/BlazeVector.fsproj +++ b/Projects/BlazeVector/BlazeVector.fsproj @@ -1,5 +1,7 @@ + + Debug @@ -14,6 +16,8 @@ 4.4.3.0 BlazeVector + + true @@ -85,11 +89,6 @@ {85d631a5-821a-4755-a68e-c1ffc64e469a} True - - Prime - {fe09ae81-b66b-42e0-8192-eadecefc9893} - True - Nu.SDL2 {f184a111-8c28-40b4-8cde-7bf2a64b3ca7} @@ -99,10 +98,16 @@ ..\..\Nu\Nu.Dependencies\Farseer\FarseerPhysics.dll - ..\..\Prime\Prime.Dependencies\FParsec\FParsec.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsec.dll - ..\..\Prime\Prime.Dependencies\FParsec\FParsecCS.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsecCS.dll + + + ..\..\packages\FsCheck.2.10.10\lib\net452\FsCheck.dll + + + ..\..\packages\FsCheck.Xunit.2.10.10\lib\net452\FsCheck.Xunit.dll ..\..\Nu\Nu.Dependencies\FSharpx.Collections\FSharpx.Collections.dll @@ -114,6 +119,9 @@ True + + ..\..\packages\Prime.2.7.0\lib\net46\Prime.exe + ..\..\Nu\Nu.Dependencies\SDL2#\Release\SDL2#.dll @@ -121,7 +129,7 @@ - ..\..\Prime\Prime.Dependencies\System.ValueTuple.4.3.0\lib\portable-net40+sl4+win8+wp8\System.ValueTuple.dll + ..\..\packages\System.ValueTuple.4.4.0\lib\netstandard1.0\System.ValueTuple.dll ..\..\Nu\Nu.Dependencies\TiledSharp\Release\TiledSharp.dll @@ -132,16 +140,16 @@ True - ..\..\Prime\Prime.Dependencies\xunit\xunit.abstractions.dll + ..\..\packages\xunit.abstractions.2.0.1\lib\net35\xunit.abstractions.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.assert.dll + ..\..\packages\xunit.assert.2.3.1\lib\netstandard1.1\xunit.assert.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.core.dll + ..\..\packages\xunit.extensibility.core.2.3.1\lib\netstandard1.1\xunit.core.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.execution.desktop.dll + ..\..\packages\xunit.extensibility.execution.2.3.1\lib\net452\xunit.execution.desktop.dll @@ -151,4 +159,13 @@ + + + This project references NuGet package(s) that are missing on this computer. Use NuGet Package Restore to download them. For more information, see http://go.microsoft.com/fwlink/?LinkID=322105. The missing file is {0}. + + + + + + \ No newline at end of file diff --git a/Projects/BlazeVector/Packages.config b/Projects/BlazeVector/Packages.config index 77b54a2758..febaef4574 100644 --- a/Projects/BlazeVector/Packages.config +++ b/Projects/BlazeVector/Packages.config @@ -1,4 +1,17 @@  + + + + + + + + + + + + + \ No newline at end of file diff --git a/Projects/InfinityRpg/InfinityRpg.fsproj b/Projects/InfinityRpg/InfinityRpg.fsproj index 655da6eea7..ba16383e52 100644 --- a/Projects/InfinityRpg/InfinityRpg.fsproj +++ b/Projects/InfinityRpg/InfinityRpg.fsproj @@ -1,5 +1,7 @@ + + Debug @@ -14,6 +16,8 @@ 4.4.3.0 InfinityRpg + + true @@ -104,11 +108,6 @@ {85d631a5-821a-4755-a68e-c1ffc64e469a} True - - Prime - {fe09ae81-b66b-42e0-8192-eadecefc9893} - True - Nu.SDL2 {f184a111-8c28-40b4-8cde-7bf2a64b3ca7} @@ -118,10 +117,16 @@ ..\..\Nu\Nu.Dependencies\Farseer\FarseerPhysics.dll - ..\..\Prime\Prime.Dependencies\FParsec\FParsec.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsec.dll - ..\..\Prime\Prime.Dependencies\FParsec\FParsecCS.dll + ..\..\packages\FParsec.1.0.3\lib\net40-client\FParsecCS.dll + + + ..\..\packages\FsCheck.2.10.10\lib\net452\FsCheck.dll + + + ..\..\packages\FsCheck.Xunit.2.10.10\lib\net452\FsCheck.Xunit.dll ..\..\Nu\Nu.Dependencies\FSharpx.Collections\FSharpx.Collections.dll @@ -133,6 +138,9 @@ True + + ..\..\packages\Prime.2.7.0\lib\net46\Prime.exe + ..\..\Nu\Nu.Dependencies\SDL2#\Release\SDL2#.dll @@ -145,26 +153,35 @@ True - ..\..\Prime\Prime.Dependencies\System.ValueTuple.4.3.0\lib\portable-net40+sl4+win8+wp8\System.ValueTuple.dll + ..\..\packages\System.ValueTuple.4.4.0\lib\netstandard1.0\System.ValueTuple.dll ..\..\Nu\Nu.Dependencies\TiledSharp\Release\TiledSharp.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.abstractions.dll + ..\..\packages\xunit.abstractions.2.0.1\lib\net35\xunit.abstractions.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.assert.dll + ..\..\packages\xunit.assert.2.3.1\lib\netstandard1.1\xunit.assert.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.core.dll + ..\..\packages\xunit.extensibility.core.2.3.1\lib\netstandard1.1\xunit.core.dll - ..\..\Prime\Prime.Dependencies\xunit\xunit.execution.desktop.dll + ..\..\packages\xunit.extensibility.execution.2.3.1\lib\net452\xunit.execution.desktop.dll + + + This project references NuGet package(s) that are missing on this computer. Use NuGet Package Restore to download them. For more information, see http://go.microsoft.com/fwlink/?LinkID=322105. The missing file is {0}. + + + + + + \ No newline at end of file diff --git a/Projects/InfinityRpg/Packages.config b/Projects/InfinityRpg/Packages.config index 77b54a2758..febaef4574 100644 --- a/Projects/InfinityRpg/Packages.config +++ b/Projects/InfinityRpg/Packages.config @@ -1,4 +1,17 @@  + + + + + + + + + + + + + \ No newline at end of file