dirty-haskell.org: events
https://dirty-haskell.org
Fri, 27 May 2016 00:00:00 UTOn the Design of a Turing-Complete Appointment Book
https://dirty-haskell.org/posts/events/01.html
{-# LANGUAGE TemplateHaskell #-}
> {-# LANGUAGE MultiParamTypeClasses #-}
> {-# LANGUAGE FlexibleInstances #-}
> {-# LANGUAGE UndecidableInstances #-}
>
> module Events.Types
> ( TimeRange(..), rangeStart, rangeDuration
> , Event(..), payload, occursWithin
> , EvalCtx(..), ctxVars, ctxEvents
> , ObjCtx(..), objOccurs, objPayload
> , Eval, evaluate
> , module Data.Aeson
> , module Data.Time.Clock
> , module Data.Default.Class
> ) where
>
> import Control.Lens.TH
>
> import Data.Aeson (Object)
>
> import Data.Time.Clock
>
> import Control.Monad.State.Lazy
> import ListT (ListT)
> import qualified ListT
>
> import Data.Default.Class
>
> import Data.Monoid
> import Control.Monad.Fix
> import Control.Lens
> import Data.Maybe
We can quite easily encode an interval of time as a lower bound and a
duration:
> data TimeRange = TimeRange
> { _rangeStart :: UTCTime
> , _rangeDuration :: NominalDiffTime
> }
> makeLenses ''TimeRange
For our purposes it´s sufficient to consider an event to be some data
we´ll display when needed and some way to determine whether the given
`TimeRange`{.haskell} intersects it:
> data Event = Event
> { _payload :: Object
> , _occursWithin :: TimeRange -> Bool
> }
> makeLenses ''Event
We are going to want to parse a specification of some kind into a form we can run.
Below we see one such form.
`ListT`{.haskell} allows for nondeterministic computation – it allows us to split
our worldline[^worldlineSplits] and continue depth-first much like `[]`{.haskell}.
Within every worldline we modify a distinct snapshot of `ObjCtx`{.haskell} we took
while branching.
We also share one `EvalCtx`{.haskell} across all worldlines.
> type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a
`ListT`{.haskell} does not ship with extensive support for the
[transformers package][transformers][^pipes]:
> instance MonadState s m => MonadState s (ListT m) where
> get = lift get
> put = lift . put
The context shared among all worldlines mainly contains all objects that
eventually get computed – haskells lazyness ensures that we terminate as
long as we don´t have objects depend on themselves in a sufficiently
degenerate way[^degenerate].
> data EvalCtx = EvalCtx
> { _ctxEvents :: [Object]
> } deriving (Show)
> makeLenses ''EvalCtx
>
> instance Default EvalCtx where
> def = EvalCtx
> { _ctxEvents = mempty
> }
Every worldline constructs exactly one object while having access to a set
of declarations that can occur anywhere on the worldline[^ctxVars].
> data ObjCtx = ObjCtx
> { _objOccurs :: Bool
> , _objPayload :: Maybe Object
> , _objVars :: Object
> }
> makeLenses ''ObjCtx
>
> instance Default ObjCtx where
> def = ObjCtx
> { _objOccurs = False
> , _objPayload = Nothing
> , _objVars = mempty
> }
Constructing an `Object`{.haskell} from an `ObjCtx`{.haskell} is straightforward:
> objCtx :: ObjCtx -> Maybe Object
> objCtx (ObjCtx False _) = Nothing
> objCtx (ObjCtx True o) = o
`mfix`{.haskell} allows all values contained within our various `StateT`{.haskell}
layers to depend on one another:
> evaluate :: MonadFix m => Eval m () -> m [Object]
> evaluate x = catMaybes <$> mfix x'
> where
> x' = evalStateT (ListT.toList (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes
[^ctxVars]: In the base version of this file we carry declarations we may refer to when
creating objects (`_objVars`{.haskell}) within `EvalCtx`{.haskell} instead of `ObjCtx`{.haskell}.
Why is that a bad idea?
[^worldlineSplits]: What does such a branching point look like in do notation?
[^pipes]: It has been pointed out to me that `ListT`{.haskell} from [pipes][] does.
[^degenerate]: Constructing an example that doesn´t terminate is trivial. Try constructing one that does while
still being self-referential!
[Google Calendar]:
[Remind]:
[JSON]:
[monad transformers]:
[transformers]:
[pipes]:
]]>Fri, 27 May 2016 00:00:00 UThttps://dirty-haskell.org/posts/events/01.htmlG. KleenA Monad Encoding Co-Total Lists Admitting Cutoff-Rules
https://dirty-haskell.org/posts/events/02.html
[Object]
filterTime = filter $ maybe False (\t -> qDate <= t && t <= qDate') <$> view (objPayload . key "date" . asDate)
qDate = fromGregorian 2016 08 01
qDate' = fromGregorian 2016 08 07
~~~
Due to `fromFoldable [1..]`{.haskell} this will surely never terminate yet it is obvious that the question, whether the week from 2016-08-01 to 2016-08-07 contains one of our series of events, is answerable in finite time.
We would like to be able to employ constructions like the one above for the sake of convenience – it is often the case that we don´t yet know when a regularly scheduled appointment will stop taking place.
Ensuring that our list-comprehensions always terminate is of course the halting problem – we can however employ some trickery to make rather simple constructs, like the one above, work.
To do so in our concrete application we leverage the fact that, at evaluation time, we always know which `TimeRange`{.haskell} we´re interested in and can stop, given that we generate new `Event`{.haskell}s only monotonically in time, checking new `Event`{.haskell}s exactly when we encounter the first in our worldline which lies entirely after our `TimeRange`{.haskell}.
> {-# LANGUAGE GADTs #-}
> {-# LANGUAGE TupleSections #-}
> {-# LANGUAGE ViewPatterns #-}
> {-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
>
> module Events.Types.NDT
> ( NDT
> , foldNDT
> , cons
> , fromFoldable
> ) where
>
> import Data.Monoid
> import Data.Foldable (foldr)
> import Data.Maybe
> import Data.Either
>
> import Control.Applicative (Alternative)
> import qualified Control.Applicative as Alt (Alternative(..))
> import Control.Monad
> import Control.Monad.Identity
>
> import Control.Monad.Trans
>
> data NDT m a where
> NDTBind :: NDT m a -> (a -> NDT m b) -> NDT m b
> NDTCons :: m (Maybe (a, NDT m a)) -> NDT m a
`NDT m a`{.haskell} as defined above is essentially just `m [a]`{.haskell}.
The more involved construction, reminiscent of [`Free`{.haskell}][][^usingFree] is owed to the fact that stopping to evaluate after some criterion requires that criterion be known; we´d have to save it in `NDT`{.haskell}, which is incompatible with `return`{.haskell}.
What follows are some fairly straight forward and not particularly interesting instances needed essentially for making `NDT`{.haskell} into a proper monad-transformer.
> instance Functor m => Functor (NDT m) where
> fmap f (NDTBind a g) = NDTBind a (fmap f . g)
> fmap f (NDTCons x) = NDTCons $ fmap f' x
> where
> f' Nothing = Nothing
> f' (Just (x, xs)) = Just (f x, fmap f xs)
>
> instance Applicative m => Applicative (NDT m) where
> pure x = NDTCons . pure $ Just (x, empty)
> fs <*> xs = fs >>= (\f -> xs >>= pure . (f $))
>
> instance Applicative m => Monad (NDT m) where
> return = pure
> (>>=) = NDTBind
>
> instance Monad m => Monoid (NDT m a) where
> mempty = empty
> mappend (NDTCons x) y'@(NDTCons y) = NDTCons $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x
> mappend (NDTBind x f) (NDTBind y g) = NDTBind (fmap Left x <> fmap Right y) (either f g)
> mappend x@(NDTBind _ _) y = x <> NDTBind y return
> mappend x y@(NDTBind _ _) = NDTBind x return <> y
>
> instance MonadTrans NDT where
> lift = NDTCons . fmap Just . fmap (,empty)
>
> instance Monad m => Alternative (NDT m) where
> empty = mempty
> (<|>) = mappend
>
> instance Monad m => MonadPlus (NDT m) where
> mzero = mempty
> mplus = mappend
>
> instance MonadIO m => MonadIO (NDT m) where
> liftIO = lift . liftIO
>
> empty :: Applicative m => NDT m a
> empty = NDTCons $ pure Nothing
>
> cons :: Applicative m => a -> NDT m a -> NDT m a
> cons x xs = NDTCons . pure $ Just (x, xs)
>
> fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
> fromFoldable = foldr cons empty
The evaluation function below implements the pruning behaviour described above:
> foldNDT :: (Foldable f, Applicative f, Monoid (f a), Monad m) => (a -> m Bool) -> NDT m a -> m (f a)
> -- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings and children
Cons-cells are rather straightforward – iff the head doesn´t fulfil our criterion we ignore both it and the tail:
> foldNDT sel (NDTCons mx) = do
> mx' <- mx
> case mx' of
> Nothing -> return mempty
> Just (x, mxs) -> do
> continue <- sel x
> case continue of
> False -> return mempty
> True -> (pure x <>) <$> foldNDT sel mxs
This encodes pruning children of cons-cells which don´t satisfy the criterion in our tree composed of `NDTCons`{.haskell} and `NDTBind`{.haskell}.
Deferred bind operations (`NDTBind`{.haskell}) are somewhat more involved.
To make handling them easier we first squash `NDTBind`{.haskell}s such that the only children of `NDTBind`{.haskell}s are always cons-cells.
> foldNDT sel (NDTBind (NDTBind x g) f) = foldNDT sel $ NDTBind x (f <=< g)
The desired pruning behaviour for `NDTBind`{.haskell}s is as follows: iff evaluating the tree produced by applying `f`{.haskell} to the head of the cons-cell does not produce a valid object we discard the tail, too[^unproductivePaths].
> foldNDT sel (NDTBind (NDTCons x) f) = do
> x' <- x
> case x' of
> Nothing -> return mempty
> Just (x'', xs) -> do
> x3 <- foldNDT sel $ f x''
> xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f)
> return $ x3 <> xs'
Using the above the following now works:
~~~ {.haskell}
(Yaml.encode <=< evaluate predicate) $ do
n <- lift $ NDT.fromFoldable ([1..] :: [Integer])
objOccurs .= (n >= 2)
objPayload ?= [ ("num", Yaml.Number $ fromIntegral n)
]
where
predicate :: Monad m => Maybe Yaml.Object -> m Bool
predicate = ordPredicate $ maybe LT (`compare` 5) . view (at "num" . asDouble)
ordPredicate :: Applicative m => (Object -> Ordering) -> (Maybe Object -> m Bool)
ordPredicate _ Nothing = pure True
ordPredicate f (Just (f -> o)) = pure $ o <= EQ -- View Patterns
~~~
[^brokenExample]: Neither `fromFoldable`{.haskell} nor `asDate`{.haskell} currently exist. I didn´t even bother to see whether the example typechecks.
[^usingFree]: I am confident that `NDT`{.haskell} could be alternatively constructed using the monad-transformer version of `Free`{.haskell}: [`FreeT`{.haskell}][]
[^unproductivePaths]: Currently this discards trees which don´t produce valid objects not because they produce invalid ones (which is our stated termination-criterion) but because they don´t produce anything at all. I´ll probably end up changing that after I find a case where that´s a problem (Care to provide one?).
[`ListT`{.haskell}]:
[`Free`{.haskell}]:
[`FreeT`{.haskell}]: https://hackage.haskell.org/package/free/docs/Control-Monad-Trans-Free.html#t:FreeT<>
]]>Fri, 29 Jul 2016 00:00:00 UThttps://dirty-haskell.org/posts/events/02.htmlG. Kleen