The main application scaffolding. You can write a really pretty top level like this:
myOrbiter : OrbiterOutput MyAction MyModel Layout.Item Error
myOrbiter =
myProgram
`withSequenceInputs`
[ someVeryImportantBrowserEnvironmentInput
, someOtherOutsideSignal
]
`orbitsWithWork`
(computeTask doMyComplicatedStartupWork withThisData)
+--> (it'sErrorTap myErrorHandler)
+--> itself
main : Signal Graphics.Element.Element
main = Layout.fromItem <~ myOrbiter.view'
port sink : Signal (Task z ())
port sink = sieve myOrbiter
Represents the status of a given OrbiterAgent. Orbiter agents are a way of transforming the results of arbitrary tasks in to actions and errors for the program to consume.
A ComputedResult is a Result which may be a ComputedSuccess or some error type on failure. This
is used as the output type of the function passed to a computeTask
.
This is the success type of an OrbiterTask. It consists of a sequence of actions to execute, and
a tag saying whether we want the actions executed all at once, or spread out asynchronously. This
should be treated as opaque; use the constructors computedSuccess
and computedSuccessAsync
.
This is the input type for Orbiter. It can be seen as roughly analogous to StartApp's Config type, but carries the full configuration and input in one. This should be considered opaque.
This is the output of an Orbiter program. This is not intended to be opaque. Any part of the output structure is up for grabs. I do not reccomend usage of the lazyAddress externally.
view' Signal with the current view.
model' Signal with the current model.
now Signal with the most recent execution time.
actions Signal with the most recently atomically executed action list.
tasks Signal with the most recent OrbiterTask output.
address The address of the Orbiter program's Mailbox.
This represents an instantaneous description of an Orbiter program. It consists of the current model and a possible TaskDispatchment. This should be treated as opaque.
OrbiterTap is an alias for functions that transform OrbiterTasks by routing their actions to an address. You will probably not need to directly provide an OrbiterTap function, as the built in family of taps should be sufficient for just about any application.
A task with a ComputedSuccess result. These are used as the output task type of the Orbiter.
This is an opaque type representing an ordered list of tasks to execute. This is quite similar to Effects batching.
Represents the output of the update
and stage
functions configured in the OrbiterInput.
This type exists so that TaskDispatchments and OrbiterTasks can be cleanly included in the output
of stage
and update
without the need to return an ugly pair or embed anything in the model.
Represents the output of the present
function configured in the OrbiterInput.
This type exists so that TaskDispatchments and OrbiterTasks can be cleanly included in the output
of present
without the need to return an ugly pair or embed anything in the model.
defProgram is the old declaration form for defining OrbiterInput. It is simpler, and does not
support the stage
function. Internally this uses the new form, but it has been left in for
two reasons. One is of course backwards compatibility, but sometimes you just don't need that
extra firepower, in which case it is mere clutter.
defProgram is the old declaration form for defining OrbiterInput. It is simpler, and does not
support the stage
function. Internally this uses the new form, but it has been left in for
two reasons. One is of course backwards compatibility, but sometimes you just don't need that
extra firepower, in which case it is mere clutter.
Run an orbiter without any startup task.
orbits (myProgram `withSequenceInputs` [myInput, myInput2])
This is the workhorse of Gigan.Core. Given an OrbiterInput and some starting OrbiterTask, run the Orbiter program described by the input to give an OrbiterOutput.
withInputs is the oldest way in Gigan of using action inputs, from before we started using lists of actions. Lists of actions are much more powerful because not only can they be used to make sure sequences of actions run atomically, but it also gives us an obvious and tagless way to represent noop. Here's how it looked:
defProgram myPresent myUpdate myModel0 `withInputs` [actionSignal0, actionSignal1]
This is DEPRECIATED.
Since action lists are internally combined using lazy lists, one may want to just hand over their LazyList without converting it to a list. This may sometimes be appropriate, but beware of unbounded laziness. Profiling is your friend here.
withSequenceInputs is the preferred way of piping outside sources of actions in to an orbiter program. You'll notice from the way this is used that OrbiterInput definitions made by defProgram' or defProgram refrain from including any inputs right away. The reason for this is that a program and the source of it's input are two distinctly separate concerns, though the content of it's input is not. In Stem, the inputs of an OrbiterInput are not used. This way, OrbiterInput is also usable for defining Stem state machines as well as Orbiter programs.
defProgram' myPresent myStage myUpdate myModel0 `withSequenceInputs` [actionListSignal0, actionListSignal1]
The sieve is the final stop for OrbiterOutput. This should be attached at a port to get your tasks running.
Give an UpdatedModel from a model, carrying an empty TaskDispatchment.
Give a ViewOutput from your view type, carrying an empty TaskDispatchment.
Add some tasks to the output of any of the three Orbiter functions.
updated model `withTasks` [actionTask [Jump, Run]]
presented viewstuff `withTasks` [errorTask [reportError "You done goofed."]]
This is definitely the most elegant way to build a TaskDispatchment as well, especially in the context of declaring causality.
This is the same as withTasks
, but it takes an already existing TaskDispatchment.
This takes a list of UpdatedModel or ViewOutput instances, and appends each one to the TaskDispatchment of the current output. This is preferred when doing model composition with Stem. For example:
staged { collectionModel | memberViews = memberOutputs } `withChildren` memberOutputs
where memberOutputs is a list of stemPresent or stemPresentAs outputs in the example.
Get an OrbiterTask from a ViewOutput. This is DEPRECIATED. Use TaskDispatchment wherever possible.
An OrbiterTask that carries a list of actions to execute atomically.
Note that a tap which is explicitly from the *Async
family of taps will override this behavior,
instead producing the same behavior as actionTaskAsync. For that reason, asynchronous taps should
mainly be used for one-way data flows that are not dependent on ordering.
An OrbiterTask that carries a list of actions to execute asynchronously, meaning they may be interspersed with other feedback and inputs.
An OrbiterTask that carries an error.
An OrbiterTask that obtains some ComputedResult from user provided data and a user provided function, which is invoked during execution of the task. This just gives us basic support for deferred computations.
Produce a normal ComputedSuccess from a list of actions. These actions will be sent all at once, and thus will be executed atomically.
Produce an asynchronous ComputedSuccess from a list of actions. These actions will be sent one by one from sequential tasks, and thus their execution will be spread out with no guarantee that the sequence of actions will be executed atomically.
If you need to run a list of a few thousand actions,
and it is safe for those actions to be interspersed with other actions, you may be looking at a very
good use case for this function. Note also that this will never preempt an action list that is sent
at once using computeSuccess
, which is a product of how the Elm runtime works.
A list of no actions.
An OrbiterTask that does nothing and produces noActions.
This is the most essential tap for almost any application. It routes the actions resulting from your TaskDispatchment output back to the program's main address.
Same as itself, but execute action lists asynchronously, such that they may be interspersed with other action lists.
Route the resulting actions from your TaskDispatchments to some action list address.
Same as thisAddress, but asynchronously as described above.
Same as thisAddress, but with forwarding.
Same as thisForwardAddress, but asynchronously as described above.
Transform any errors in to lists of actions, then route them to the address.
Same as thisTap but uses Address forwarding to transform action lists in to some other target type for your address.
A tap defined using an OrbiterTap and some address. The OrbiterTasks that pass through this tap will be routed to the given address. This is a bit lower level than is needed in most cases.
Combine two TaskDispatchment instances. This appends the task list of the second to the task list of the first.
Collapse two action tasks by executing them sequentially and appending their resulting action outputs.
Turn a list of OrbiterTasks in to a TaskDispatchment.
True iff the TaskDispatchment has at least one OrbiterTask.
Turn a TaskDispatchment in to an OrbiterTask. Doing this will make things a lot more opaque, so ask yourself if it is absolutely neccessary first. Mainly this is included for completeness.
Using some transformation function, create a TaskDispatchment with a different action type.
Constructor for an OrbiterSnapshot. I reccomend using the Stem module instead of these functions.
Add a dispatchment to an OrbiterSnapshot.
Get the pending TaskDispatchment out of an OrbiterSnapshot and clear it from the snapshot in one go. This gives an ugly pair. See the newer interface for this in Stem, and also see the way Knowledge works. It seems much better to separate this in to two stages. It leaves room for a mistake, which I was trying to avoid, but it's so much cleaner than way that it's worth it and actually leads to fewer mistakes as a result.
Run the present
phase on an OrbiterSnapshot, yielding a ViewOutput.
Run the stage
phase on an OrbiterSnapshot.
Run the update
phase on an OrbiterSnapshot.
Perform a full cycle on an OrbiterSnapshot. This looks like:
state
|> orbiterSnapshotUpdate input actions now
|> orbiterSnapshotStage input address now
|> orbiterSnapshotDispatch
internally. The point of performCycle is to be used in foldp, which it is inside orbitsWithWork and orbits (which really just calls orbitsWithWork with nilTask).
Successful OrbiterAgent output.
Failed OrbiterAgent output.
The basic orbiter agent. Takes two functions, one of which transforms a successful result in to an AgentStatus, and one which does the same for task failure results. This transforms an arbitrary task in to an OrbiterTask. Notice that we can easily succeed anyway even if the task failed, or vice versa, because we get an AgentStatus which may be successful or failing either way. This means you can skip error handling altogether if you already know what to do with the failure from the scope you're in; you can simply map the failure on to some actions that perform an appropriate contingency.
This is a combination of orbiterAgent and orbiterBinary agent which processes successful results to get an AgentStatus, otherwise giving the failed agent status.
This is a combination of orbiterAgent and orbiterBinary agent which gives the successful agent status in the case of success, and processes failed results to get an AgentStatus otherwise .
A binary orbiter agent. This does not process any of the results, but simply always gives the succesful AgentStatus (the first one) on task success, otherwise it gives the failed AgentStatus.
If we don't care about the outcome of a task because it can't fail or produce a meaningful result, we can just queue up something to do after it's done. This is perfect for using delay tasks.
No matter what, do nothing. This will get your task to run, but no kind of action or error feedback will be produced.
The other orbiter agents defined so far are less succinct because they take two arguments, one which applies to the success case and one which applies to the failure case. This one takes a single function which processes the task's outcome as a Result, and so is generally a bit shorter to write.
This makes any error in to noActions.
{--
Copyright (c) 2016, William Whitacre
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted
provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this list of conditions
and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions
and the following disclaimer in the documentation and/or other materials provided with the
distribution.
3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse
or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--}
module Gigan.Core
(AgentStatus, ComputedResult, ComputedSuccess, OrbiterInput, OrbiterOutput, OrbiterSnapshot,
OrbiterTap, OrbiterTask, TaskDispatchment, UpdatedModel, ViewOutput,
defProgram, defProgram',
orbits, orbitsWithWork, withInputs, withLazySequenceInputs, withSequenceInputs, sieve, (+-->),
updated, presented, withTasks, withDispatchment, withChildren, viewOutputTask,
actionTask, actionTaskAsync, errorTask, computeTask, computedSuccess, computedSuccessAsync,
noActions, nilTask,
itself, itselfAsync, it'sErrorTap, thisAddress, thisAddressAsync, thisForwardAddress,
thisForwardAddressAsync, thisErrorTap, thisForwardTap, thisTap,
combineDispatchments, collapseTasks, dispatchTasks, dispatchmentHasWork, dispatchmentTask,
promoteDispatchment,
orbiterSnapshot, orbiterSnapshotAddDispatchment, orbiterSnapshotDispatch,
orbiterSnapshotPresent, orbiterSnapshotStage, orbiterSnapshotUpdate, performCycle,
orbiterAgentSuccess, orbiterAgentFailure, orbiterAgent, orbiterSuccessAgent, orbiterFailureAgent,
orbiterBinaryAgent, orbiterBlindAgent, orbiterNilAgent, orbiterResultAgent, ignoreError)
where
{-| The main application scaffolding. You can write a really pretty top level like this:
myOrbiter : OrbiterOutput MyAction MyModel Layout.Item Error
myOrbiter =
myProgram
`withSequenceInputs`
[ someVeryImportantBrowserEnvironmentInput
, someOtherOutsideSignal
]
`orbitsWithWork`
(computeTask doMyComplicatedStartupWork withThisData)
+--> (it'sErrorTap myErrorHandler)
+--> itself
main : Signal Graphics.Element.Element
main = Layout.fromItem <~ myOrbiter.view'
port sink : Signal (Task z ())
port sink = sieve myOrbiter
# Definitions
@docs AgentStatus, ComputedResult, ComputedSuccess, OrbiterInput, OrbiterOutput, OrbiterSnapshot, OrbiterTap, OrbiterTask, TaskDispatchment, UpdatedModel, ViewOutput
# Define Orbiter Programs
@docs defProgram, defProgram'
# Run Orbiter Programs
@docs orbits, orbitsWithWork, withInputs, withLazySequenceInputs, withSequenceInputs, sieve, (+-->)
# UpdatedModel and ViewOutput Manipulation
@docs updated, presented, withTasks, withDispatchment, withChildren, viewOutputTask
# Dispatch Actions and Errors
@docs actionTask, actionTaskAsync, errorTask, computeTask, computedSuccess, computedSuccessAsync, noActions, nilTask
# Intercept and Route Action and Error Outputs
@docs itself, itselfAsync, it'sErrorTap, thisAddress, thisAddressAsync, thisForwardAddress, thisForwardAddressAsync, thisErrorTap, thisForwardTap, thisTap
# Handling Tasks and TaskDispatchment
@docs combineDispatchments, collapseTasks, dispatchTasks, dispatchmentHasWork, dispatchmentTask, promoteDispatchment
# Manipulate Orbiter Snapshots
@docs orbiterSnapshot, orbiterSnapshotAddDispatchment, orbiterSnapshotDispatch, orbiterSnapshotPresent, orbiterSnapshotStage, orbiterSnapshotUpdate, performCycle
# Orbiter Task Agents
@docs orbiterAgentSuccess, orbiterAgentFailure, orbiterAgent, orbiterSuccessAgent, orbiterFailureAgent, orbiterBinaryAgent, orbiterBlindAgent, orbiterNilAgent, orbiterResultAgent, ignoreError
-}
import Signal
import Signal.Extra exposing ((<~), (~>), (~))
import Debug
import Result
import Task exposing (Task, andThen, onError)
import Task.Extra
import Lazy.List exposing (LazyList, (:::), (+++))
import Time exposing (Time)
type FeedbackMethod =
Atomically | Asynchronously
{-| A task with a ComputedSuccess result. These are used as the output task type of the Orbiter. -}
type alias OrbiterTask bad a = Task bad (ComputedSuccess a)
{-| A ComputedResult is a Result which may be a ComputedSuccess or some error type on failure. This
is used as the output type of the function passed to a `computeTask`. -}
type alias ComputedResult bad a = Result bad (ComputedSuccess a)
{-| This is the success type of an OrbiterTask. It consists of a sequence of actions to execute, and
a tag saying whether we want the actions executed all at once, or spread out asynchronously. This
should be treated as opaque; use the constructors `computedSuccess` and `computedSuccessAsync`. -}
type alias ComputedSuccess a =
{ sequence : List a
, method : FeedbackMethod
}
{-| This is the input type for Orbiter. It can be seen as roughly analogous to StartApp's Config
type, but carries the full configuration and input in one. This should be considered opaque. -}
type alias OrbiterInput a b c bad =
{ inputs : LazyList (Signal (LazyList a)) -- lazy list used here to reduce aggregation time
, model0 : b
, present : Signal.Address (List a) -> Time -> b -> ViewOutput a c bad
, stage : Signal.Address (List a) -> Time -> b -> UpdatedModel a b bad
, update : a -> Time -> b -> UpdatedModel a b bad
}
{-| This represents an instantaneous description of an Orbiter program. It consists of the current
model and a possible TaskDispatchment. This should be treated as opaque. -}
type alias OrbiterSnapshot a b bad =
{ model' : b
, dispatchment : TaskDispatchment bad a
}
{-| This is the output of an Orbiter program. This is not intended to be opaque. Any part of the
output structure is up for grabs. I do not reccomend usage of the lazyAddress externally.
view' Signal with the current view.
model' Signal with the current model.
now Signal with the most recent execution time.
actions Signal with the most recently atomically executed action list.
tasks Signal with the most recent OrbiterTask output.
address The address of the Orbiter program's Mailbox.
-}
type alias OrbiterOutput a b c bad =
{ view' : Signal c
, model' : Signal b
, now : Signal Time
, actions : Signal (List a) -- as a matter of robustness, we should forcibly reduce actions
-- action to normal lists so that no spacetime leaks occur on
-- account of unbounded laziness.
, tasks : Signal (OrbiterTask bad a)
, address : Signal.Address (List a)
, lazyAddress : Signal.Address (LazyList a) -- a performance boost where you want it,
-- simplicity where it's unneeded
}
{-| This is an opaque type representing an ordered list of tasks to execute. This is quite similar
to Effects batching. -}
type alias TaskDispatchment bad a =
{ taskExec : LazyList (OrbiterTask bad a)
}
{-| Represents the output of the `update` and `stage` functions configured in the OrbiterInput.
This type exists so that TaskDispatchments and OrbiterTasks can be cleanly included in the output
of `stage` and `update` without the need to return an ugly pair or embed anything in the model. -}
type alias UpdatedModel a b bad =
{ dispatchment : TaskDispatchment bad a
, model' : b
}
{-| Represents the output of the `present` function configured in the OrbiterInput.
This type exists so that TaskDispatchments and OrbiterTasks can be cleanly included in the output
of `present` without the need to return an ugly pair or embed anything in the model. -}
type alias ViewOutput a c bad =
{ dispatchment : TaskDispatchment bad a
, view' : c
}
{-| OrbiterTap is an alias for functions that transform OrbiterTasks by routing their actions to
an address. You will probably not need to directly provide an OrbiterTap function, as the built in
family of taps should be sufficient for just about any application. -}
type alias OrbiterTap bad a =
(Signal.Address (List a) -> OrbiterTask bad a -> OrbiterTask bad a)
{-| A list of no actions. -}
noActions : List a
noActions = []
{-| Produce a normal ComputedSuccess from a list of actions. These actions will be sent all at once,
and thus will be executed atomically. -}
computedSuccess : List a -> ComputedSuccess a
computedSuccess actions =
{ sequence = actions, method = Atomically }
{-| Produce an asynchronous ComputedSuccess from a list of actions. These actions will be sent
one by one from sequential tasks, and thus their execution will be spread out with no guarantee that
the sequence of actions will be executed atomically.
If you need to run a list of a few thousand actions,
and it is safe for those actions to be interspersed with other actions, you may be looking at a very
good use case for this function. Note also that this will never preempt an action list that is sent
at once using `computeSuccess`, which is a product of how the Elm runtime works. -}
computedSuccessAsync : List a -> ComputedSuccess a
computedSuccessAsync actions =
{ sequence = actions, method = Asynchronously }
{-| An OrbiterTask that does nothing and produces noActions. -}
nilTask : OrbiterTask bad a
nilTask = actionTask noActions
{-| An OrbiterTask that carries a list of actions to execute atomically.
Note that a tap which is explicitly from the `*Async` family of taps will override this behavior,
instead producing the same behavior as actionTaskAsync. For that reason, asynchronous taps should
mainly be used for one-way data flows that are not dependent on ordering. -}
actionTask : List a -> OrbiterTask bad a
actionTask actions = Task.succeed (computedSuccess actions)
{-| An OrbiterTask that carries a list of actions to execute asynchronously, meaning they may be
interspersed with other feedback and inputs. -}
actionTaskAsync : List a -> OrbiterTask bad a
actionTaskAsync actions = Task.succeed (computedSuccessAsync actions)
{-| An OrbiterTask that carries an error. -}
errorTask : bad -> OrbiterTask bad a
errorTask error' = Task.fail (error')
{-| An OrbiterTask that obtains some ComputedResult from user provided data and a user provided
function, which is invoked during execution of the task. This just gives us basic support for
deferred computations. -}
computeTask : (data -> ComputedResult bad a) -> data -> OrbiterTask bad a
computeTask compute' data =
let
computation data =
case compute' data of
Result.Ok result -> Task.succeed result
Result.Err err -> Task.fail err
in
(Task.succeed ()) `andThen` (\_ -> computation data)
atomicSuccessTap_ : Signal.Address (List a) -> OrbiterTask bad a -> OrbiterTask bad a
atomicSuccessTap_ address task =
let
extractedSequence = task `andThen` (\x -> Task.succeed x.sequence)
in
(Task.Extra.interceptSuccess address extractedSequence)
`andThen` actionTask
asyncSuccessTap_ : Signal.Address (List a) -> OrbiterTask bad a -> OrbiterTask bad a
asyncSuccessTap_ address task =
let
fitting act prior =
prior `andThen` \_ -> atomicSuccessTap_ address <| actionTask [act]
spread sequenceDispatcher =
List.foldl fitting nilTask sequenceDispatcher.sequence
in
task `andThen` spread
|> Task.Extra.interceptSuccess (Signal.forwardTo address .sequence)
successTap_ : Signal.Address (List a) -> OrbiterTask bad a -> OrbiterTask bad a
successTap_ address task =
let
attachFitting result =
Task.succeed result
|> case result.method of
Atomically -> atomicSuccessTap_ address
Asynchronously -> asyncSuccessTap_ address
in
task `andThen` attachFitting
errorTap_ : Signal.Address (List a) -> (bad -> List a) -> OrbiterTask bad a -> OrbiterTask bad a
errorTap_ address errorActionTransform task =
Signal.forwardTo address errorActionTransform
|> flip Task.Extra.interceptError task
{-| This makes any error in to noActions. -}
ignoreError : bad -> List a
ignoreError = always noActions
{-| defProgram is the old declaration form for defining OrbiterInput. It is simpler, and does not
support the `stage` function. Internally this uses the new form, but it has been left in for
two reasons. One is of course backwards compatibility, but sometimes you just don't need that
extra firepower, in which case it is mere clutter. -}
defProgram
: (Signal.Address (List a) -> Time -> b -> ViewOutput a c bad)
-> (a -> Time -> b -> UpdatedModel a b bad)
-> b
-> OrbiterInput a b c bad
defProgram present update model = defProgram' present (\_ _ m' -> updated m') update model
{-| defProgram' is the complete way to define an OrbiterInput. OrbiterInput is configured with
three functions. `update` and `present` should be familiar to users of StartApp, except for the
fact that they always have the current time. `stage` is a special addition which allows one to
use the program Mailbox address from a context in which the model can be updated.
The use case for `stage` which inspired it's existence is as follows: suppose you have a really
big model with a really, really big view. There is enough data that keen algorithms and data
structures, as well as avoiding redundant computations during presentation becomes a neccessity.
You can then structure your application as follows. Represent all these components as instances of
Stem. From inside `stage`, you can present _only the ones that will or should actually be seen_,
and cache the results in the model. Since you can create an updated model from here, you can save
anything that may be later needed during presentation.
`stage` is called only once after an entire list of actions is executed. If you get a list of 1000
actions, you can still guarantee the work in stage will be done only once, before presentation.
_The primary reason stage has access to the address is because it enables you to call present on
any sub components ahead of time for caching purposes._ -}
defProgram'
: (Signal.Address (List a) -> Time -> b -> ViewOutput a c bad)
-> (Signal.Address (List a) -> Time -> b -> UpdatedModel a b bad)
-> (a -> Time -> b -> UpdatedModel a b bad)
-> b
-> OrbiterInput a b c bad
defProgram' present stage update model =
{ inputs = Lazy.List.empty
, model0 = model
, present = present
, update = update
, stage = stage
}
{-
e.g. defProgram present update model0 `withSequenceInputs` myInputs
-}
{-| withInputs is the oldest way in Gigan of using action inputs, from before we started using
lists of actions. Lists of actions are much more powerful because not only can they be used to
make sure sequences of actions run atomically, but it also gives us an obvious and tagless way to
represent noop. Here's how it looked:
defProgram myPresent myUpdate myModel0 `withInputs` [actionSignal0, actionSignal1]
This is DEPRECIATED.
-}
withInputs : OrbiterInput a b c bad -> List (Signal a) -> OrbiterInput a b c bad
withInputs inR sigs =
{ inR
| inputs = inR.inputs +++ (List.foldr (\x ls -> (x ~> Lazy.List.singleton) ::: ls) Lazy.List.empty sigs)
}
{-| withSequenceInputs is the preferred way of piping outside sources of actions in to an orbiter
program. You'll notice from the way this is used that OrbiterInput definitions made by defProgram'
or defProgram refrain from including any inputs right away. The reason for this is that a program
and the _source_ of it's input are two distinctly separate concerns, though the _content_ of it's
input is not. In Stem, the inputs of an OrbiterInput are not used. This way, OrbiterInput is also
usable for defining Stem state machines as well as Orbiter programs.
defProgram' myPresent myStage myUpdate myModel0 `withSequenceInputs` [actionListSignal0, actionListSignal1]
-}
withSequenceInputs : OrbiterInput a b c bad -> List (Signal (List a)) -> OrbiterInput a b c bad
withSequenceInputs inR sigs =
{ inR
| inputs = inR.inputs +++ (List.foldr (\x ls -> (x ~> Lazy.List.fromList) ::: ls) Lazy.List.empty sigs)
}
-- An alternative lazy list address for cases where you really need lazy lists for the performance
-- boost.
{-| Since action lists are internally combined using lazy lists, one may want to just hand over their
LazyList without converting it to a list. This may sometimes be appropriate, but beware of unbounded
laziness. Profiling is your friend here. -}
withLazySequenceInputs : OrbiterInput a b c bad -> List (Signal (LazyList a)) -> OrbiterInput a b c bad
withLazySequenceInputs inR sigs =
{ inR
| inputs = inR.inputs +++ (List.foldr (\x ls -> x ::: ls) Lazy.List.empty sigs)
}
{-| Turn a list of OrbiterTasks in to a TaskDispatchment. -}
dispatchTasks : List (OrbiterTask bad a) -> TaskDispatchment bad a
dispatchTasks = Lazy.List.fromList >> dispatchment_
{-| Turn a TaskDispatchment in to an OrbiterTask. Doing this will make things a lot more opaque,
so ask yourself if it is absolutely neccessary first. Mainly this is included for completeness. -}
dispatchmentTask : TaskDispatchment bad a -> OrbiterTask bad a
dispatchmentTask = reduceDispatchment_
{-| True iff the TaskDispatchment has at least one OrbiterTask. -}
dispatchmentHasWork : TaskDispatchment bad a -> Bool
dispatchmentHasWork dispatchment =
(Lazy.List.length dispatchment.taskExec) > 0
{-| Get an OrbiterTask from a ViewOutput. This is DEPRECIATED. Use TaskDispatchment wherever
possible. -}
viewOutputTask : ViewOutput a c bad -> OrbiterTask bad a
viewOutputTask output = output.dispatchment |> dispatchmentTask
{-| Combine two TaskDispatchment instances. This appends the task list of the second to the task
list of the first. -}
combineDispatchments : TaskDispatchment bad a -> TaskDispatchment bad a -> TaskDispatchment bad a
combineDispatchments dsp dsp' =
{ dsp | taskExec = dsp.taskExec +++ dsp'.taskExec }
{-| Using some transformation function, create a TaskDispatchment with a different action type. -}
promoteDispatchment : (List a -> List a') -> TaskDispatchment bad a -> TaskDispatchment bad a'
promoteDispatchment xdcr dsp =
{ dsp
| taskExec =
Lazy.List.map
(\task -> task `andThen` \a0 -> actionTask (xdcr a0.sequence))
dsp.taskExec
}
{-| Add some tasks to the output of any of the three Orbiter functions.
updated model `withTasks` [actionTask [Jump, Run]]
presented viewstuff `withTasks` [errorTask [reportError "You done goofed."]]
This is definitely the most elegant way to build a TaskDispatchment as well, especially in the
context of declaring causality.
-}
withTasks
: List (OrbiterTask bad a)
-> { anything | dispatchment : TaskDispatchment bad a }
-> { anything | dispatchment : TaskDispatchment bad a }
withTasks tasks out' =
{ out'
| dispatchment = dispatch_ out'.dispatchment tasks
}
{-| This is the same as `withTasks`, but it takes an already existing TaskDispatchment. -}
withDispatchment
: TaskDispatchment bad a
-> { anything | dispatchment : TaskDispatchment bad a }
-> { anything | dispatchment : TaskDispatchment bad a }
withDispatchment dispatchment out' =
{ out'
| dispatchment = combineDispatchments out'.dispatchment dispatchment
}
{-| This takes a list of UpdatedModel or ViewOutput instances, and appends each one to the
TaskDispatchment of the current output. This is preferred when doing model composition with Stem.
For example:
staged { collectionModel | memberViews = memberOutputs } `withChildren` memberOutputs
where memberOutputs is a list of stemPresent or stemPresentAs outputs in the example.
-}
withChildren
: List { anything | dispatchment : TaskDispatchment bad a }
-> { anything | dispatchment : TaskDispatchment bad a }
-> { anything | dispatchment : TaskDispatchment bad a }
withChildren children out' =
{ out'
| dispatchment = List.foldl
(\ch dsp -> combineDispatchments dsp ch.dispatchment)
out'.dispatchment
children
}
-- ORBITER AGENTS
--
-- These primitives are designed to make it more concise to specify complex branching contingencies
-- in tasks before closing them off either with error reports (see "taps", such as it'sErrorTap).
-- or with lists of actions to execute on success. We allow control over whether or not something is
-- interpreted as success or failure at a level that enables total intervention, so business logic
-- complexity is not limited when constructing contingency graphs (task branching). Using the Elm
-- Architecture as per usual, we can have logarithmic code size.
--
{-| Represents the status of a given OrbiterAgent. Orbiter agents are a way of transforming the
results of arbitrary tasks in to actions and errors for the program to consume. -}
type AgentStatus bad a =
AgentSuccess (List a)
| AgentFailure bad
{-| Successful OrbiterAgent output. -}
orbiterAgentSuccess : List a -> AgentStatus bad a
orbiterAgentSuccess actions =
AgentSuccess actions
{-| Failed OrbiterAgent output. -}
orbiterAgentFailure : bad -> AgentStatus bad a
orbiterAgentFailure err' =
AgentFailure err'
agentStatusResult status =
case status of
AgentSuccess ls -> Task.succeed (Result.Ok (computedSuccess ls))
AgentFailure err' -> Task.succeed (Result.Err err')
{-| The basic orbiter agent. Takes two functions, one of which transforms a successful result in to
an AgentStatus, and one which does the same for task failure results. This transforms an arbitrary
task in to an OrbiterTask. Notice that we can easily succeed anyway even if the task failed, or vice
versa, because we get an AgentStatus which may be successful or failing either way. This means you
can skip error handling altogether if you already know what to do with the failure from the scope
you're in; you can simply map the failure on to some actions that perform an appropriate
contingency. -}
orbiterAgent : (x -> AgentStatus bad a) -> (y -> AgentStatus bad a) -> Task y x -> OrbiterTask bad a
orbiterAgent onSuccess onFailure task =
(task
`andThen` (onSuccess >> agentStatusResult)
`onError` (onFailure >> agentStatusResult))
`andThen`
\result ->
case result of
Result.Ok computedSuccess -> Task.succeed computedSuccess
Result.Err problem -> Task.fail problem
{-| A binary orbiter agent. This does not process any of the results, but simply always gives the
succesful AgentStatus (the first one) on task success, otherwise it gives the failed AgentStatus. -}
orbiterBinaryAgent : AgentStatus bad a -> AgentStatus bad a -> Task y x -> OrbiterTask bad a
orbiterBinaryAgent onSuccessResult onFailureResult =
orbiterAgent (always onSuccessResult) (always onFailureResult)
{-| This is a combination of orbiterAgent and orbiterBinary agent which processes successful results
to get an AgentStatus, otherwise giving the failed agent status. -}
orbiterSuccessAgent : (x -> AgentStatus bad a) -> AgentStatus bad a -> Task y x -> OrbiterTask bad a
orbiterSuccessAgent onSuccess onFailureResult =
orbiterAgent onSuccess (always onFailureResult)
{-| This is a combination of orbiterAgent and orbiterBinary agent which gives the successful agent
status in the case of success, and processes failed results to get an AgentStatus otherwise . -}
orbiterFailureAgent : AgentStatus bad a -> (y -> AgentStatus bad a) -> Task y x -> OrbiterTask bad a
orbiterFailureAgent onSuccessResult onFailure =
orbiterAgent (always onSuccessResult) onFailure
{-| The other orbiter agents defined so far are less succinct because they take two arguments, one
which applies to the success case and one which applies to the failure case. This one takes a single
function which processes the task's outcome as a Result, and so is generally a bit shorter to write. -}
orbiterResultAgent : (Result y x -> AgentStatus bad a) -> Task y x -> OrbiterTask bad a
orbiterResultAgent produceResult =
orbiterAgent (Result.Ok >> produceResult) (Result.Err >> produceResult)
{-| If we don't care about the outcome of a task because it can't fail or produce a meaningful
result, we can just queue up something to do after it's done. This is perfect for using delay tasks. -}
orbiterBlindAgent : AgentStatus bad a -> Task y x -> OrbiterTask bad a
orbiterBlindAgent result =
orbiterBinaryAgent result result
{-| No matter what, do nothing. This will get your task to run, but no kind of action or error
feedback will be produced. -}
orbiterNilAgent : Task y x -> OrbiterTask bad a
orbiterNilAgent =
orbiterBlindAgent (AgentSuccess [])
dispatchment_
: LazyList (OrbiterTask bad a)
-> TaskDispatchment bad a
dispatchment_ taskExec =
{ taskExec = taskExec
}
dispatch_
: TaskDispatchment bad a
-> List (OrbiterTask bad a)
-> TaskDispatchment bad a
dispatch_ dispatchment seq =
{ dispatchment
| taskExec = dispatchment.taskExec +++ (Lazy.List.fromList seq)
}
reduceDispatchment_ : TaskDispatchment bad a -> OrbiterTask bad a
reduceDispatchment_ dispatchmentRecord =
Lazy.List.foldl
(\task task' ->
task
`andThen` \a0 -> task'
`andThen` \a1 -> actionTask (List.append a0.sequence a1.sequence)
)
(actionTask [])
dispatchmentRecord.taskExec
-- TEARS OF :JOY:
{-| The sieve is the final stop for OrbiterOutput. This should be attached at a port to get your
tasks running. -}
sieve : OrbiterOutput a b c bad -> Signal (Task z ())
sieve q'' =
q''.tasks ~> \task' -> {-Debug.log "TASK RCV"-} task'
`andThen` (\final -> {-Debug.log "TASK OK"-} final |> \_ -> Task.succeed ())
`onError` (\err -> {-Debug.log "ERROR"-} err |> \_ -> Task.succeed ())
{--
--}
{-| Give an UpdatedModel from a model, carrying an empty TaskDispatchment. -}
updated : b -> UpdatedModel a b bad
updated model =
{ model' = model
, dispatchment = dispatchment_ Lazy.List.empty
}
{-| Give a ViewOutput from your view type, carrying an empty TaskDispatchment. -}
presented : c -> ViewOutput a c bad
presented view =
{ view' = view
, dispatchment = dispatchment_ Lazy.List.empty
}
{-| Run an orbiter without any startup task.
orbits (myProgram `withSequenceInputs` [myInput, myInput2])
-}
orbits : OrbiterInput a b c bad -> OrbiterOutput a b c bad
orbits defs =
defs `orbitsWithWork` nilTask
{-| Constructor for an OrbiterSnapshot. I reccomend using the Stem module instead of these functions. -}
orbiterSnapshot : b -> TaskDispatchment bad a -> OrbiterSnapshot a b bad
orbiterSnapshot model0 dispatchment =
{ dispatchment = dispatchment
, model' = model0 }
{-| Add a dispatchment to an OrbiterSnapshot. -}
orbiterSnapshotAddDispatchment : TaskDispatchment bad a -> OrbiterSnapshot a b bad -> OrbiterSnapshot a b bad
orbiterSnapshotAddDispatchment dispatchment' { dispatchment, model' } =
{ dispatchment = combineDispatchments dispatchment dispatchment'
, model' = model'
}
{-| Run the `update` phase on an OrbiterSnapshot. -}
orbiterSnapshotUpdate
: { k | update : a -> Time -> b -> UpdatedModel a b bad }
-> List a
-> Time
-> OrbiterSnapshot a b bad
-> OrbiterSnapshot a b bad
orbiterSnapshotUpdate { update } actions now state =
let
applyAction action state =
update action now state.model'
|> \updated' -> orbiterSnapshotAddDispatchment
updated'.dispatchment
{ state | model' = updated'.model' }
in
List.foldl applyAction state actions
{-
, present : (Signal.Address (List a) -> Time -> b -> ViewOutput a c bad)
, stage : (Signal.Address (List a) -> Time -> b -> UpdatedModel a b bad)
, update : (a -> Time -> b -> UpdatedModel a b bad)
-}
{-| Run the `stage` phase on an OrbiterSnapshot. -}
orbiterSnapshotStage
: { k | stage : Signal.Address (List a) -> Time -> b -> UpdatedModel a b bad }
-> Signal.Address (List a)
-> Time
-> OrbiterSnapshot a b bad
-> OrbiterSnapshot a b bad
orbiterSnapshotStage { stage } address now state =
stage address now state.model'
|> \{dispatchment, model'} ->
orbiterSnapshotAddDispatchment dispatchment { state | model' = model' }
{-| Run the `present` phase on an OrbiterSnapshot, yielding a ViewOutput. -}
orbiterSnapshotPresent
: { k | present : Signal.Address (List a) -> Time -> b -> ViewOutput a c bad }
-> Signal.Address (List a)
-> Time
-> OrbiterSnapshot a b bad
-> ViewOutput a c bad
orbiterSnapshotPresent { present } address now state =
present address now state.model'
{-| Get the pending TaskDispatchment out of an OrbiterSnapshot and clear it from the snapshot in
one go. This gives an _ugly pair_. See the newer interface for this in Stem, and also see the way
Knowledge works. It seems much better to separate this in to two stages. It leaves room for a mistake,
which I was trying to avoid, but it's so much cleaner than way that it's worth it and actually
leads to fewer mistakes as a result. -}
orbiterSnapshotDispatch : OrbiterSnapshot a b bad -> (OrbiterSnapshot a b bad, TaskDispatchment bad a)
orbiterSnapshotDispatch state =
(,)
{ state
| dispatchment = dispatchTasks []
}
state.dispatchment
{-| Collapse two action tasks by executing them sequentially and appending their resulting action
outputs. -}
collapseTasks : OrbiterTask bad a -> OrbiterTask bad a -> OrbiterTask bad a
collapseTasks task task' =
task `andThen` \a0 -> task' `andThen` \a1 -> actionTask (List.append a0.sequence a1.sequence)
{-| Perform a full cycle on an OrbiterSnapshot. This looks like:
state
|> orbiterSnapshotUpdate input actions now
|> orbiterSnapshotStage input address now
|> orbiterSnapshotDispatch
internally. The point of performCycle is to be used in foldp, which it is inside orbitsWithWork
and orbits (which really just calls orbitsWithWork with nilTask).
-}
performCycle
: OrbiterInput a b c bad
-> Signal.Address (List a)
-> (Time, List a)
-> (OrbiterSnapshot a b bad, TaskDispatchment bad a)
-> (OrbiterSnapshot a b bad, TaskDispatchment bad a)
performCycle input address (now, actions) (state, _) =
state
|> orbiterSnapshotUpdate input actions now
|> orbiterSnapshotStage input address now
|> orbiterSnapshotDispatch
{-| This is the workhorse of Gigan.Core. Given an OrbiterInput and some starting OrbiterTask,
run the Orbiter program described by the input to give an OrbiterOutput. -}
orbitsWithWork : OrbiterInput a b c bad -> OrbiterTask bad a -> OrbiterOutput a b c bad
orbitsWithWork orbiterInput startupTask =
let
{ inputs, model0, present, stage, update } = orbiterInput
actionMailbox = Signal.mailbox Lazy.List.empty
publicAddress = Signal.forwardTo actionMailbox.address Lazy.List.fromList
aggregatedInputs =
Lazy.List.foldl
(Signal.Extra.fairMerge (+++))
(Signal.constant Lazy.List.empty)
(actionMailbox.signal ::: inputs)
inputSignal = Time.timestamp (aggregatedInputs ~> Lazy.List.toList)
orbiterFold =
Signal.foldp
(performCycle orbiterInput publicAddress)
(dispatchTasks [startupTask] |> orbiterSnapshot model0, dispatchTasks [])
inputSignal
orbiterFoldTimestamps = inputSignal ~> fst
orbiterFoldSnapshots = orbiterFold ~> fst
orbiterFoldDispatchments = orbiterFold ~> snd
views = orbiterSnapshotPresent orbiterInput publicAddress <~ orbiterFoldTimestamps ~ orbiterFoldSnapshots
combinedDispatchments =
Signal.Extra.fairMerge
-- model (update/stage) tasks go before view (present) tasks
combineDispatchments
orbiterFoldDispatchments
(.dispatchment <~ views)
-- NOTE IMPORTANT: This filter is crucial to avoiding a busy loop!
filteredTasks =
Signal.filterMap
(\dispatchment -> if dispatchmentHasWork dispatchment then Just (dispatchmentTask dispatchment) else Nothing)
nilTask
combinedDispatchments
outputConfig =
{ view' = views ~> .view'
, model' = orbiterFoldSnapshots ~> .model'
, tasks = filteredTasks
, now = inputSignal ~> fst
, actions = inputSignal ~> snd
, address = publicAddress
, lazyAddress = actionMailbox.address
-- TODO factor the current time in to the orbiter _output_
}
in
outputConfig
-- NOTE : This is an alias for |>, but is intended to make opaque the semantics of an _orbiter_ and
-- it's _taps_. This is done so that one needn't reason about function application at all to install
-- taps. Instead, think of +--> as meaning "and then flows in to".
{-| While it may be a case of "your stupid infix operator", I think it makes writing taps nicer
simply because I see `+---> itself` and I think "oh, it has an edge going to itself". This is one
of those instances where the abstraction can actually help with comprehension because it acually looks
like a directed graph edge. See the main example for usage. _NOTE: you can use (|>) to be more
standard._ -}
(+-->) : OrbiterOutput a b c bad -> (OrbiterOutput a b c bad -> OrbiterOutput a b c bad) -> OrbiterOutput a b c bad
(+-->) output portal =
portal output
{-| A tap defined using an OrbiterTap and some address. The OrbiterTasks that pass through this tap will be
routed to the given address. This is a bit lower level than is needed in most cases. -}
thisTap
: OrbiterTap bad a
-> Signal.Address (List a)
-> OrbiterOutput a b c bad
-> OrbiterOutput a b c bad
thisTap tap address output =
{ output | tasks = output.tasks ~> (tap address) }
{-| Same as thisTap but uses Address forwarding to transform action lists in to some other target type
for your address. -}
thisForwardTap : OrbiterTap bad a -> Signal.Address target -> (List a -> target) -> OrbiterOutput a b c bad -> OrbiterOutput a b c bad
thisForwardTap tap address f output =
thisTap tap (Signal.forwardTo address f) output
{-| This is the most essential tap for almost any application. It routes the actions resulting from your TaskDispatchment output back to the program's main address. -}
itself : OrbiterOutput a b c bad -> OrbiterOutput a b c bad
itself output =
thisTap successTap_ output.address output
{-| Same as itself, but execute action lists asynchronously, such that they may be interspersed with other action lists. -}
itselfAsync : OrbiterOutput a b c bad -> OrbiterOutput a b c bad
itselfAsync output =
thisTap asyncSuccessTap_ output.address output
{-| Route the resulting actions from your TaskDispatchments to some action list address. -}
thisAddress : Signal.Address (List a) -> OrbiterOutput a b c bad -> OrbiterOutput a b c bad
thisAddress address output =
thisTap successTap_ address output
{-| Same as thisAddress, but with forwarding. -}
thisForwardAddress : Signal.Address target -> (List a -> target) -> OrbiterOutput a b c bad -> OrbiterOutput a b c bad
thisForwardAddress address f output =
thisForwardTap successTap_ address f output
{-| Same as thisAddress, but asynchronously as described above. -}
thisAddressAsync : Signal.Address (List a) -> OrbiterOutput a b c bad -> OrbiterOutput a b c bad
thisAddressAsync address output =
thisTap asyncSuccessTap_ address output
{-| Same as thisForwardAddress, but asynchronously as described above. -}
thisForwardAddressAsync : Signal.Address target -> (List a -> target) -> OrbiterOutput a b c bad -> OrbiterOutput a b c bad
thisForwardAddressAsync address f output =
thisForwardTap asyncSuccessTap_ address f output
{-| Transform any errors in to lists of actions, then route them to the address. -}
thisErrorTap : Signal.Address (List a) -> (bad -> List a) -> OrbiterOutput a b c bad -> OrbiterOutput a b c bad
thisErrorTap address handler output =
thisTap (flip errorTap_ handler) address output
{-| Same semantics as `itself`, but for errors. Error taps do not have an asynchronous alternative. -}
it'sErrorTap : (bad -> List a) -> OrbiterOutput a b c bad -> OrbiterOutput a b c bad
it'sErrorTap handler output =
thisErrorTap output.address handler output