mirror of
https://github.com/marcosh/crem.git
synced 2024-10-26 11:52:20 +03:00
improvements from Alex code review
This commit is contained in:
parent
478e907b33
commit
0f1fe42893
@ -199,7 +199,7 @@ a │ ┌╌╌╌╌┐ [b] ┌╌╌╌╌┐ │ [c]
|
||||
|
||||
where the outputs `bs :: [b]` of the first machine are is passed as inputs to the second machine, and processed all one by one.
|
||||
|
||||
Notice that in fact everything works not only for lists, but for every foldable type.
|
||||
We used lists `[b]` here to denote multiple outputs, but we can in fact use any [`Foldable`](https://hackage.haskell.org/package/base/docs/Prelude.html#t:Foldable) type.
|
||||
|
||||
## `Basic`
|
||||
|
||||
@ -244,7 +244,7 @@ We use a `Topology vertex` kind, and we construct types of that kind using the `
|
||||
|
||||
To define a `Topology`, we first need to define the type of its vertices.
|
||||
|
||||
This is usually done by defining an enumeration of the vertices, like
|
||||
A straightforward approach is to define an enumeration of vertices, like
|
||||
|
||||
```haskell
|
||||
data ExampleVertex
|
||||
|
@ -25,11 +25,15 @@ data ReceivedData = ReceivedData
|
||||
|
||||
instance Semigroup ReceivedData where
|
||||
(<>) :: ReceivedData -> ReceivedData -> ReceivedData
|
||||
(<>) (ReceivedData ud1 ld1 cbd1) (ReceivedData ud2 ld2 cbd2) =
|
||||
r1 <> r2 =
|
||||
ReceivedData
|
||||
(getLast $ Last ud1 <> Last ud2)
|
||||
(getLast $ Last ld1 <> Last ld2)
|
||||
(getLast $ Last cbd1 <> Last cbd2)
|
||||
{ receivedUserData =
|
||||
getLast $ Last (receivedUserData r1) <> Last (receivedUserData r2)
|
||||
, receivedLoanDetails =
|
||||
getLast $ Last (receivedLoanDetails r1) <> Last (receivedLoanDetails r2)
|
||||
, receivedCreditBureauData =
|
||||
getLast $ Last (receivedCreditBureauData r1) <> Last (receivedCreditBureauData r2)
|
||||
}
|
||||
|
||||
instance Monoid ReceivedData where
|
||||
mempty :: ReceivedData
|
||||
|
@ -40,8 +40,9 @@ otherLoanDetails =
|
||||
creditBureauData :: CreditBureauData
|
||||
creditBureauData =
|
||||
CreditBureauData
|
||||
(MissedPaymentDeadlines 2)
|
||||
(EuroCents 100000)
|
||||
{ missedPaymentDeadlines = MissedPaymentDeadlines 2
|
||||
, arrears = EuroCents 100000
|
||||
}
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
|
@ -149,6 +149,8 @@ instance Functor m => Functor (ActionResult m topology state initialVertex) wher
|
||||
fmap f (ActionResult outputStatePair) =
|
||||
ActionResult $ first f <$> outputStatePair
|
||||
|
||||
-- | Create an `ActionResult` without performing any side effect in the `m`
|
||||
-- context
|
||||
pureResult
|
||||
:: (Applicative m, AllowedTransition topology initialVertex finalVertex)
|
||||
=> output
|
||||
@ -156,15 +158,20 @@ pureResult
|
||||
-> ActionResult m topology state initialVertex output
|
||||
pureResult output state = ActionResult . pure $ (output, state)
|
||||
|
||||
-- | This is fairly similar to `sequenceA` from `Traversable` and in fact it
|
||||
-- does the same job, with the slight difference that `sequenceA` would return
|
||||
-- `f (ActionResult Identity topology state initialVertex output)`
|
||||
sequence
|
||||
:: ActionResult Identity topology state initialVertex [output]
|
||||
-> ActionResult [] topology state initialVertex output
|
||||
:: Functor f
|
||||
=> ActionResult Identity topology state initialVertex (f output)
|
||||
-> ActionResult f topology state initialVertex output
|
||||
sequence (ActionResult (Identity (outputs, state))) =
|
||||
ActionResult $ (,state) <$> outputs
|
||||
|
||||
-- ** Stateless machines
|
||||
|
||||
-- | The `statelessBaseT` transforms its input to its output and never changes its state
|
||||
-- | `statelessBaseT` transforms its input to its output and never changes its
|
||||
-- state
|
||||
statelessBaseT :: Applicative m => (a -> m b) -> BaseMachineT m (TrivialTopology @()) a b
|
||||
statelessBaseT f =
|
||||
BaseMachineT
|
||||
@ -173,6 +180,8 @@ statelessBaseT f =
|
||||
ActionResult $ (,state) <$> f input
|
||||
}
|
||||
|
||||
-- | `statelessBase` transforms its input to its output and never changes its
|
||||
-- state, without performing any side effect
|
||||
statelessBase :: (a -> b) -> BaseMachine (TrivialTopology @()) a b
|
||||
statelessBase f = statelessBaseT (pure . f)
|
||||
|
||||
|
@ -31,17 +31,22 @@ transitiveClosureGraph graph@(Graph edges) =
|
||||
Graph $
|
||||
foldr
|
||||
( \a edgesSoFar ->
|
||||
edgesSoFar <> pathsStartingWith graph a
|
||||
edgesSoFar <> pathsFrom graph a
|
||||
)
|
||||
[]
|
||||
(nub $ fst <$> edges)
|
||||
where
|
||||
pathsStartingWith :: Eq a => Graph a -> a -> [(a, a)]
|
||||
pathsStartingWith graph'@(Graph edges') a =
|
||||
edgesFrom :: Eq a => Graph a -> a -> [(a, a)]
|
||||
edgesFrom (Graph edges') a = filter ((== a) . fst) edges'
|
||||
|
||||
pathsFrom :: forall a. Eq a => Graph a -> a -> [(a, a)]
|
||||
pathsFrom g a =
|
||||
let
|
||||
edgesStartingWithA = filter ((== a) . fst) edges'
|
||||
edgesFromAToB = edgesFrom g a
|
||||
pathsFromBToC = edgesFromAToB >>= pathsFrom g . snd
|
||||
edgesFromAToC = (a,) . snd <$> pathsFromBToC
|
||||
in
|
||||
edgesStartingWithA <> ((a,) . snd <$> (pathsStartingWith graph' . snd =<< edgesStartingWithA))
|
||||
edgesFromAToB <> edgesFromAToC
|
||||
|
||||
-- * UntypedGraph
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user