I apologize upfront for all the code following this question. Its included to answer any questions -- I hope.
In Elmish.WPF, I have submodels of submodels of submodels. Each submodel is esentially a list.
That is, I have a main DataGrid, an "AppointmentTable", bound to a Rows list. Each Row has a column list; Each column has a cell list. Lastly each cell is bound to a name.
Updating each of these models takes more time then I am willing to wait. I have two questions; I a mostly interested in the concepts involved:
Can each submodel use Cmd.OfAsync.either where only ONE delay is made when ALL the models are updated and screen updated, and
Would there be any way of running all submodels asynchrounously in parrellel?
TIA
WPF:
<!--DataContext is MainWindow.fs-->
<TabControl ...>
<TabItem Header="Appointments">
<Grid DataContext="{Binding Appointments}">
<local:Appointments Grid.Column="2" Grid.Row="0" />
</Grid>
</TabItem>
<!--DataContext from MainWindow ="{Binding Appointments}"-->
<DataGrid Grid.Row="1" x:Name = "AppointmentTable" ItemsSource="{Binding Rows}" ...>
<DataGrid.Columns>
<DataGridTemplateColumn.CellTemplate>
<DataTemplate>
<Grid DataContext="{Binding Columns[0]}">
<ListView ItemsSource="{Binding InnerRows}"
<ListView.View>
<GridView>
<GridViewColumn Header="First" Width="100">
<GridViewColumn.CellTemplate>
<DataTemplate>
<TextBlock Text="{Binding Path=FirstName}"/>
</DataTemplate>
</GridViewColumn.CellTemplate>
</GridViewColumn>
<GridViewColumn Header="Last" Width="120">
<GridViewColumn.CellTemplate>
<DataTemplate>
<TextBlock Text="{Binding Path=LastName}"/>
</DataTemplate>
</GridViewColumn.CellTemplate>
</GridViewColumn>
<GridViewColumn Header="Bd" Width="80">
<GridViewColumn.CellTemplate>
<DataTemplate>
<TextBlock Text="{Binding Path=BirthDate}"/>
</DataTemplate>
</GridViewColumn.CellTemplate>
</GridViewColumn>
</GridView>
</ListView.View>
</ListView>
</Grid>
</DataTemplate>
</DataGridTemplateColumn.CellTemplate>
</DataGridTemplateColumn>
----------------------------------------------------------------------------------------------------
F#
module Mainwindow
type Model =
{ Appointments: Appointments.Model
......
}
// DataContext for Appointments.xaml
"Appointments"
|> Binding.SubModel.required Appointments.bindings
|> Binding.mapModel (fun m -> m.Appointments)
|> Binding.mapMsg AppointmentsMsg
module Appointments
type Model =
{ Rows: Row.Model list
}
"Rows" |> Binding.subModelSeq(
(fun m -> m.Rows),
(fun (m, outerRowModel) -> (m.SelectedOuterRow = Some outerRowModel.Id, outerRowModel)),
(fun (_, outerRowModel) -> outerRowModel.Id),
RowMsg,
Row.bindings)
module Row =
type Model =
{ Columns: Column.Model list
...}
"Columns" |> Binding.subModelSeq(
(fun (_, outerRowModel) -> outerRowModel.Columns),
(fun ((b, outerRowModel), columnModel) -> (b && outerRowModel.SelectedColumn = Some columnModel.ColumnId, columnModel)),
(fun (_, columnModel) -> columnModel.ColumnId),
ColumnMsg,
Column.bindings)
module Column =
type Model =
{ Cells: Cell.Model list
....
}
"InnerRows" |> Binding.subModelSeq(
(fun (_, m) -> m.Cells),
(fun ((_, m), cellmodel) -> (m.SelectedCellId = Some cellmodel.Id, cellmodel) ),
(fun (_, cellmodel) -> cellmodel.Id),
snd,
Cell.bindings)
module Cell =
type Model =
{ Id: int
AppointmentTime: DateTime
Appointment: Visit option }
let bindings() = [
"LastName" |> Binding.oneWay(fun (_, c) ->
match c.Appointment with
| Some a -> a.LastName
| None -> ""
)
"FirstName" |> Binding.oneWay(fun (_, c) ->
match c.Appointment with
| Some a -> a.FirstName
| None -> ""
)
"BirthDate" |> Binding.oneWay(fun (_, c) ->
match c.Appointment with
| Some a -> a.BirthDate.ToShortDateString()
| None -> ""
)
"ServiceTime" |> Binding.oneWay(fun (_,c) ->
match c.Appointment with
| Some a -> a.EncounterTime
| None -> None
)
"SelectedLabel" |> Binding.oneWay (fun (b, _) -> if b then " - Selected" else "")
]
Related
I need to learn the right way to do pattern matching on Pair types:
let pairToBeFiltered = Ok ([(1,[]);(2,[3;4]);(5,[6;7;8]);(9,[]);(10,[])])
let filterEmpty (pair: int * int list) =
match pair with
| (x,y) when y <> [] -> (x,y) //This gives error because of incomplete pattern matching!
let filtering = List.map(filterEmpty) pairToBeFiltered
Desired output:
Ok([(2,[3;4]);(5,[6;7;8])])
This should do it:
let pairsToBeFiltered = Ok ([(1,[]);(2,[3;4]);(5,[6;7;8]);(9,[]);(10,[])])
let filterEmpty pairs =
List.where (fun (_, y) -> y <> []) pairs // pattern match on pair occurs here
let filtering : Result<_, string> =
pairsToBeFiltered
|> Result.map filterEmpty
printfn "%A" filtering // Ok [(2, [3; 4]); (5, [6; 7; 8])]
There are a number of issues here:
For clarity, I modified filterEmpty so it processes the entire list, rather than a single pair. This is where we apply the filtering function, List.where, using pattern matching. (In your code, note that List.map with a match expression doesn't filter anything.)
Since your list is wrapped in a Result, you need to unwrap it via Result.map in order to process it. (Since you didn't specify a 'TError type, I assumed string to pacify the compiler.)
Three more versions:
(* using match statement *)
module Version1 =
let pairsToBeFiltered : Result<_, string> =
Ok [(1,[]);(2,[3;4]);(5,[6;7;8]);(9,[]);(10,[])]
let myWhere (pair : int * List<int>) =
match pair with
| _, [] -> false
| _, _ -> true
let myFilter l0 = l0 |> Result.map (List.filter myWhere)
let result = pairsToBeFiltered |> myFilter
(* using lambda functions and List.isEmpty *)
module Version2 =
let pairsToBeFiltered : Result<_, string> =
Ok [(1,[]);(2,[3;4]);(5,[6;7;8]);(9,[]);(10,[])]
let myFilter l0 =
l0
|> Result.map (fun l1 ->
l1 |> List.filter (fun (_, l2) ->
l2 |> List.isEmpty |> not))
let result = pairsToBeFiltered |> myFilter
(* shortening Version2 (point free style - take care, can be confusing) *)
module Version3 =
let pairsToBeFiltered : Result<_, string> =
Ok [(1,[]);(2,[3;4]);(5,[6;7;8]);(9,[]);(10,[])]
let myFilter = Result.map (List.filter (snd >> List.isEmpty >> not))
let result = pairsToBeFiltered |> myFilter
I'm having an issue with a recursive function that runs into a stack overflow on larger data sets so I've attempted to rewrite the function to use continuous recursion but to say I'm new to this would be an understatement. In the below example the first function, processList, gives the desired results on a small data set. The second function, processListCont, seems to work however I know there must be a bug since when I run the same small data set through it I get different results. Would processListCont be the correct way to express the processList function or am I missing something?
open System
type Something(id) =
member val id = id with get, set
member val children : list<Something> = [] with get, set
member val processed : bool = false with get, set
let rec processList (item:Something, itemList:list<Something>) =
for child in item.children do
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
processList(parent, itemList)
let processListCont (item:Something, itemList:list<Something>) =
let rec _processListCont (item:Something, itemList:list<Something>, f) =
for child in item.children do
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
f(parent, itemList)
_processListCont(item, itemList, (fun (item:Something, itemList:list<Something>) -> ()))
[<EntryPoint>]
let main argv =
// generate some data
let count = 10000
let idList = List.init count (fun index -> index)
let items = [for (id) in idList -> Something id]
let rnd = System.Random()
for i in items do
i.children <- List.init 100 (fun _ -> Something (rnd.Next(0, count - 1)))
// process the list
for i in items do
processList(i, items)
Console.WriteLine("Processing completed successfully")
Console.ReadKey()
|> ignore
0
The main issue is that you are calling the continuation f in the body of the for loop, but your non-tail-recursive version makes a recurisve call here.
This is tricky because you want to make a recursive call and the continuation should be "run the rest of the for loop". To express this, you'll need to use pattern matching instead of for loop.
I did not have a small example to test this, but I think something like this should do the trick:
let rec processListCont (item:Something, itemList:list<Something>) cont =
let rec loop (children:list<Something>) cont =
match children with
| child::tail ->
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
processListCont (parent, itemList) (fun () -> loop tail cont)
| [] -> cont ()
loop item.children cont
Your code is unidiomatic in F# nonetheless consider the following example.
Suppose you want to add a list of numbers. You could write a function like this:
let rec add (l:int list) :int =
match l with
| [] -> 0
| x::xs -> x + (add xs)
but this would overflow the stack very quickly. Instead you could use cps to allow the code to become tail recursive:
type
cont = int -> int
let rec add2 (l:int list) (k:cont):int =
match l with
| [] -> k 0
| x::xs -> add2 xs (fun a -> k (a + x))
which you can use like this:
printfn "%i" (add2 [1..10000] id)
In a similar fashion you could rewrite your function like this:
type cont2 = Something list->unit
let rec p (item:Something, itemList:list<Something>) (k:cont2) =
match item.children with
| [] -> k []
| child::xs ->
let parent = itemList |> Seq.find (fun (i:Something) -> i.id = child.id)
if parent.processed = false then
parent.processed <- true
p (parent, itemList) (fun _ ->k xs)
else
k xs
let p2 (item:Something,itemList:Something list) = p (item,itemList) ignore
and you can call it like this:
for i in items do
p2(i, items)
I would like to work with the following type
type RecordPath<'a,'b> = {
Get: 'a -> 'b
Path:string
}
It's purpose is to define a getter for going from record type 'a to some field within 'a of type 'b. It also gives the path to that field for the json representation of the record.
For example, consider the following fields.
type DateWithoutTimeBecauseWeirdlyDotnetDoesNotHaveThisConcept = {
Year:uint
Month:uint
Day:uint
}
type Person = {
FullName:string
PassportNumber:string
BirthDate:DateWithoutTimeBecauseWeirdlyDotnetDoesNotHaveThisConcept
}
type Team = {
TeamName:string
TeamMembers:Person list
}
An example RecordPath might be
let birthYearPath = {
Get = fun (team:Team) -> team.TeamMembers |> List.map (fun p -> p.BirthDate.Year)
Path = "$.TeamMember[*].BirthDate.Year" //using mariadb format for json path
}
Is there some way of letting a library user create this record without ever actually needing to specify the string explicitly. Ideally there is some strongly typed way of the user specifying the fields involved. Maybe some kind of clever use of reflection?
It just occurred to me that with a language that supports macros, this would be possible. But can it be done in F#?
PS: I notice that I left out the s in "TeamMembers" in the path. This is the kind of thing I want to guard against to make it easier on the user.
As you noted in the comments, F# has a quotation mechanism that lets you do this. You can create those explicitly using <# ... #> notation or implicitly using a somewhat more elengant automatic quoting mechanism. The quotations are farily close representations of the F# code, so converting them to the desired path format is not going to be easy, but I think it can be done.
I tried to get this to work at least for your small example. First, I needed a helper function that does two transformations on the code and turns:
let x = e1 in e2 into e2[x <- e1] (using the notation e2[x <- e1] to mean a subsitution, i.e. expression e2 with all occurences of x replaced by e1)
e1 |> fun x -> e2 into e2[x <- e1]
This is all I needed for your example, but it's likely you'll need a few more cases:
open Microsoft.FSharp.Quotations
let rec simplify dict e =
let e' = simplifyOne dict e
if e' <> e then simplify dict e' else e'
and simplifyOne dict = function
| Patterns.Call(None, op, [e; Patterns.Lambda(v, body)])
when op.Name = "op_PipeRight" ->
simplify (Map.add v e dict) body
| Patterns.Let(v, e, body) -> simplify (Map.add v e dict) body
| ExprShape.ShapeVar(v) when Map.containsKey v dict -> dict.[v]
| ExprShape.ShapeVar(v) -> Expr.Var(v)
| ExprShape.ShapeLambda(v, e) -> Expr.Lambda(v, simplify dict e)
| ExprShape.ShapeCombination(o, es) ->
ExprShape.RebuildShapeCombination(o, List.map (simplify dict) es)
With this pre-processing, I managed to write an extractPath function like this:
let rec extractPath var = function
| Patterns.Call(None, op, [Patterns.Lambda(v, body); inst]) when op.Name = "Map" ->
extractPath var inst + "[*]." + extractPath v.Name body
| Patterns.PropertyGet(Some(Patterns.Var v), p, []) when v.Name = var -> p.Name
| Patterns.PropertyGet(Some e, p, []) -> extractPath var e + "." + p.Name
| e -> failwithf "Unexpected expression: %A" e
This looks for (1) a call to map function, (2) a property access on a variable that represents the data source and (3) a property access where the instance has some more property accesses.
The following now works for your small example (but probably for nothing else!)
type Path =
static member Make([<ReflectedDefinition(true)>] f:Expr<'T -> 'R>) =
match f with
| Patterns.WithValue(f, _, Patterns.Lambda(v, body)) ->
{ Get = f :?> 'T -> 'R
Path = "$." + extractPath v.Name (simplify Map.empty body) }
| _ -> failwith "Unexpected argument"
Path.Make(fun (team:Team) -> team.TeamMembers |> List.map (fun p -> p.BirthDate.Year))
The way I solved this is
let jsonPath userExpr =
let rec innerLoop expr state =
match expr with
|Patterns.Lambda(_, body) ->
innerLoop body state
|Patterns.PropertyGet(Some parent, propInfo, []) ->
sprintf ".%s%s" propInfo.Name state |> innerLoop parent
|Patterns.Call (None, _, expr1::[Patterns.Let (v, expr2, _)]) when v.Name = "mapping"->
let parentPath = innerLoop expr1 "[*]"
let childPath = innerLoop expr2 ""
parentPath + childPath
|ExprShape.ShapeVar x ->
state
|_ ->
failwithf "Unsupported expression: %A" expr
innerLoop userExpr "" |> sprintf "$%s"
type Path =
static member Make([<ReflectedDefinition(true)>] f:Expr<'T -> 'R>) =
match f with
|Patterns.WithValue(f, _, expr) ->
let path = jsonPath expr
{
Get = f :?> 'T -> 'R
Path = path
}
| _ -> failwith "Unexpected argument"
Caveat: I don't know enough about these techniques to tell if Tomas' answer performs better in some edge cases than mine.
I have a sequence of Result and I would like to accumulate all the Error values yet abort processing and return the first Ok value found. Specifically, I would like to abort processing the remainder of the list. Unfortunately, the approach I have preserves the first Ok found but does not abort processing the rest of the list.
let process : Result<'t, string list> -> Result<'t, string list> =
let st0 = Error []
let acc st e =
match st, e with
| Ok _ , _ -> st
| _ , Ok _ -> e
| Error v, Error vs -> Error (v ++ vs)
Seq.scan acc st0
|> Seq.last
Ideally, a Seq.skipToOrDefault and Seq.takeToOrDefault methods would be nice to have for this.
From your comments, it has become clear that what you'd like to do is to avoid iterating over the whole sequence, stopping once you encounter the first Ok.
Well, sequences already do that by default (they're lazy), and the scan function preserves that property. Let's check:
let mySeq = seq {
for i in 0..3 do
printfn "Returning %d" i
yield i
}
mySeq |> Seq.toList |> ignore
> Returning 0
> Returning 1
> Returning 2
> Returning 3
mySeq |> Seq.take 2 |> Seq.toList |> ignore
> Returning 0
> Returning 1
mySeq
|> Seq.scan (fun _ x -> printfn "Scanning %d" x) ()
|> Seq.take 3
|> Seq.toList |> ignore
> Returning 0
> Scanning 0
> Returning 1
> Scanning 1
Look: we never see "Returning 2" and "Returning 3" after the scan. That's because we're not iterating over the whole sequence, only the piece we need, as determined by Seq.take 3.
But the thing that does force the full iteration in your code is Seq.last. After all, in order to get the last element, you need to iterate over the whole sequence, there is no other way.
But what you can do is stop iteration when you need via Seq.takeWhile. This function takes a predicate and returns only the elements for which the predicate is true, excluding the first one that yields false:
mySeq |> Seq.takeWhile (fun x -> x < 2) |> Seq.toList |> ignore
> Returning 0
> Returning 1
> Returning 2
> val it : int list = [0; 1]
The difficulty in your case is that you also need to return the element that breaks the predicate. In order to do that, you can deploy a little hack: keep around in your folding state a special flag stop: bool, initially set it to false, and switch to true on the element immediately succeeding the one where you need to stop. To keep such state, I am going to use a record:
let st0 = {| prev = Error []; stop = false |}
let acc (s: {| prev: Result<_,string>; stop: bool |}) x =
match s.prev, x with
| Ok _, _ -> {| s with stop = true |} // Previous result was Ok => stop now
| _, Ok _ -> {| s with prev = x |} // Don't stop, but remember the previous result
| Error a, Error b -> {| s with prev = Error (a # b) |}
sourceSequence
|> Seq.scan acc st0
|> Seq.takeWhile (fun s -> not s.stop)
|> Seq.last
|> (fun s -> s.prev)
P.S. also note that in F# list concatenation is #, not ++. Are you coming from Haskell?
I think this is a better solution. However, there is some confusion as to whether Seq.tryPick is always side effect free regardless of the underlying sequence. For list it is such that Seq.tail is required here to advance through it...
let rec scanTo (pred:'u -> bool) (acc:'u -> 'a -> 'u) (st0:'u) (ss:'a seq) = seq {
let q =
ss
|> Seq.tryPick Some
|> Option.bind (acc st0 >> Some)
match q with
| None -> yield! Seq.empty
| Some v when pred v -> yield v
| Some v -> yield v; yield! (scanTo pred acc v (Seq.tail ss))
}
For instance...
let process : Result<'v, string list> seq -> Result<'v, string list> seq = fun aa ->
let mergeErrors acc e =
match acc, e with
| Error ms, Error m -> Error (m # ms)
| _, Ok v -> Ok v
| _, Error m -> Error m
let st0 = Error []
let isOk = function
| Ok _ -> true
| _ -> false
scanTo isOk mergeErrors st0 aa
I'm trying to implement a parser that looks something like this:
open System
type ParseResult<'a> =
{
Result : Option<'a>;
Rest : string
}
let Fail = fun input -> { Result = None; Rest = input }
let Return a = fun input -> { Result = Some a; Rest = input }
let ThenBind p f =
fun input ->
let r = p input
match r.Result with
| None -> { Result = None; Rest = input } // Recreate the result since p returns a ParseResult<'a>
| _ -> (f r.Result) r.Rest
let Then p1 p2 = ThenBind p1 (fun r -> p2)
let Or p1 p2 =
fun input ->
let r = p1 input
match r.Result with
| None -> p2 input
| _ -> r
let rec Chainl1Helper a p op =
Or
<| ThenBind op (fun f ->
ThenBind p (fun y ->
Chainl1Helper (f.Value a y.Value) p op))
<| Return a
let Chainl1 p op = ThenBind p (fun x -> Chainl1Helper x.Value p op)
let rec Chainr1 p op =
ThenBind p (fun x ->
Or
(ThenBind op (fun f ->
ThenBind (Chainr1 p op) (fun y ->
Return (f.Value x.Value y.Value))))
(Return x.Value))
let Next = fun input ->
match input with
| null -> { Result = None; Rest = input }
| "" -> { Result = None; Rest = input }
| _ -> { Result = Some <| char input.[0..1]; Rest = input.[1..] }
let Sat predicate = ThenBind Next (fun n -> if predicate n.Value then Return n.Value else Fail)
let Digit = ThenBind (Sat Char.IsDigit) (fun c -> Return <| float c.Value)
let rec NatHelper i =
Or
(ThenBind Digit (fun x ->
NatHelper (float 10 * i + x.Value) ))
(Return i)
let Nat = ThenBind Digit (fun d -> NatHelper d.Value)
let LiteralChar c = Sat (fun x -> x = c)
let rec Literal input token =
match input with
| "" -> Return token
| _ -> Then (LiteralChar <| char input.[0..1]) (Literal input.[1..] token)
let AddSub =
Or
<| ThenBind (LiteralChar '+') (fun c -> Return (+))
<| ThenBind (LiteralChar '-') (fun c -> Return (-))
let MulDiv =
Or
<| ThenBind (LiteralChar '*') (fun c -> Return (*))
<| ThenBind (LiteralChar '/') (fun c -> Return (/))
let Exp = ThenBind (LiteralChar '^') (fun c -> Return ( ** ))
let rec Expression = Chainl1 Term AddSub
and Term = Chainl1 Factor MulDiv
and Factor = Chainr1 Part Exp
and Part = Or Nat Paren
and Paren =
Then
<| LiteralChar '('
<| ThenBind Expression (fun e ->
Then (LiteralChar ')') (Return e.Value))
The last functions are mutually recursive in their definitions. Expression's definition depends on Term, which depends on Factor, which depends on Part, which depends on Paren, which depends on Expression.
When I try to compile this, I get an error about mutually recursive definitions with the suggestion to make Expression lazy or a function. I tried both of those, and I get a cryptic InvalidOperationException with both that says something about ValueFactory attempting to access the Value property.
In general, F# lets you use let rec .. and .. not just for defining mutually recursive functions, but also for defining mutually recursive values. This means that you might be able to write something like this:
let rec Expression = Chainl1 Term AddSub
and Paren =
Then
<| LiteralChar '('
<| ThenBind Expression (fun e ->
Then (LiteralChar ')') (Return e.Value))
and Part = Or Nat Paren
and Factor = Chainr1 Part Exp
and Term = Chainl1 Factor MulDiv
However, this only works if the computation is not evaluated immediately (because then the recursive definition would not make sense). This very much depends on the library you're using here (or on the rest of your code). But you can try the above and see if that works - if no, you'll need to provide more details.
EDIT In the updated example, there is an immediate loop in your recursive definition. You need to delay some part of the definition using fun _ -> ... so that not everything needs to be evaluated at once. In your example, you can do that by replacing Then with ThenBind in the definition of Paren:
let rec Expression = Chainl1 Term AddSub
and Term = Chainl1 Factor MulDiv
and Factor = Chainr1 Part Exp
and Part = Or Nat Paren
and Paren =
ThenBind
(LiteralChar '(')
(fun _ -> ThenBind Expression (fun e ->
Then (LiteralChar ')') (Return e.Value)))