From d22086666632b707aa210f20ecf10a8cd4e6d4fe Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 31 Jul 2016 00:23:23 +0200 Subject: Lambda calculus for computing events at runtime --- events/src/Events/Eval.hs | 2 +- events/src/Events/Spec.hs | 18 +++++++----------- events/src/Events/Spec/Eval.hs | 38 ++++++++++++++++++++++++++++++++++++++ events/src/Events/Spec/LICENSE | 29 +++++++++++++++++++++++++++++ events/src/Events/Spec/Types.hs | 32 ++++++++++++++++++++++++++++++++ events/src/Events/Types.hs | 20 +++++++++++++++++--- events/src/Main.hs | 2 +- 7 files changed, 125 insertions(+), 16 deletions(-) create mode 100644 events/src/Events/Spec/Eval.hs create mode 100644 events/src/Events/Spec/LICENSE create mode 100644 events/src/Events/Spec/Types.hs diff --git a/events/src/Events/Eval.hs b/events/src/Events/Eval.hs index 280c577..800b38d 100644 --- a/events/src/Events/Eval.hs +++ b/events/src/Events/Eval.hs @@ -17,7 +17,7 @@ import Control.Lens import Data.Ord (Ordering(..)) evaluate :: MonadFix m => (Maybe Object -> ReaderT EvalCtx m Bool) -> Eval m () -> m [Object] -evaluate predicate x = catMaybes <$> mfix x' +evaluate predicate (unEval -> x) = catMaybes <$> mfix x' where x' = runReaderT (foldNDT predicate (preview objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes diff --git a/events/src/Events/Spec.hs b/events/src/Events/Spec.hs index 2af3446..e098886 100644 --- a/events/src/Events/Spec.hs +++ b/events/src/Events/Spec.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, DataKinds, TypeOperators #-} module Events.Spec ( interpret - , Spec, Cmnd(..), Expr(..) + , Spec, Cmnd(..), Expr(..), Elem(..) ) where import Events.Types +import Events.Spec.Types +import Events.Spec.Eval import Control.Monad ((<=<)) import Control.Monad.IO.Class @@ -17,21 +19,15 @@ import Control.Lens import Debug.Trace -type Spec = [Expr Cmnd] -- most significant last +type Spec m = Expr (Eval m) '[] Cmnd -- most significant last data Cmnd = COverride Object | COccurs Bool | CNop deriving (Show) -data Expr a where - ELit :: a -> Expr a - -interpret :: MonadIO m => Spec -> Eval m () -interpret = mapM_ $ interpretCmnd <=< interpretExpr - -interpretExpr :: MonadIO m => Expr Cmnd -> m Cmnd -interpretExpr (ELit a) = return a +interpret :: MonadIO m => Spec m -> Eval m () +interpret = join . fmap interpretCmnd . evalExpr interpretCmnd :: MonadIO m => Cmnd -> Eval m () interpretCmnd (COverride obj) = objPayload ?= obj diff --git a/events/src/Events/Spec/Eval.hs b/events/src/Events/Spec/Eval.hs new file mode 100644 index 0000000..3a23e0b --- /dev/null +++ b/events/src/Events/Spec/Eval.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs, DataKinds, TypeOperators, RankNTypes, ScopedTypeVariables #-} + +module Events.Spec.Eval + ( evalExpr + ) where + +import Events.Spec.Types + +shift :: forall m ts2 t x. Expr m ts2 x -> Expr m (t ': ts2) x +shift = shift' LZ + where + -- shift' :: forall ts1 ts2 t x. Length ts1 -> Expr (ts1 ++ ts2) x -> Expr (ts1 ++ t ': ts2) x + shift' :: forall ts1 x. Length ts1 -> Expr m (ts1 ++ ts2) x -> Expr m (ts1 ++ t ': ts2) x + shift' _ (ELit x) = ELit x + shift' l (EVar v) = EVar $ shiftElem l v + shift' l (ELam b) = ELam $ shift' (LS l) b + shift' l (EApp f x) = EApp (shift' l f) (shift' l x) + + shiftElem :: forall ts1 u. Length ts1 -> Elem u (ts1 ++ ts2) -> Elem u (ts1 ++ t ': ts2) + shiftElem LZ e = ES e + shiftElem (LS _) EZ = EZ + shiftElem (LS l) (ES e) = ES $ shiftElem l e + + +beta = flip beta' LZ +beta' :: forall m ts1 ts2 s t. Expr m ts2 s -> Length ts1 -> Expr m (ts1 ++ s ': ts2) t -> Expr m (ts1 ++ ts2) t +beta' _ _ (ELit x) = ELit x +beta' e LZ (EVar EZ ) = e +beta' _ LZ (EVar (ES v)) = EVar v +beta' _ (LS _) (EVar EZ ) = EVar EZ +beta' e (LS l) (EVar (ES v)) = shift $ beta' e l (EVar v) +beta' e l (ELam b) = ELam $ beta' e (LS l) b +beta' e l (EApp f a) = EApp (beta' e l f) (beta' e l a) + +evalExpr :: Expr m '[] t -> Val m t +evalExpr (ELit a) = a +evalExpr (ELam a) = a +evalExpr (EApp f a) = evalExpr $ beta a (evalExpr f) diff --git a/events/src/Events/Spec/LICENSE b/events/src/Events/Spec/LICENSE new file mode 100644 index 0000000..c28fee7 --- /dev/null +++ b/events/src/Events/Spec/LICENSE @@ -0,0 +1,29 @@ +The code in siblings of this file is either heavily inspired by or copied from [glambda](https://hackage.haskell.org/package/glamba), an interpreter for a simply typed lambda-calculus by Richard Eisenberg under the following license: + +Copyright (c) 2015, Richard Eisenberg +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 author 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. \ No newline at end of file diff --git a/events/src/Events/Spec/Types.hs b/events/src/Events/Spec/Types.hs new file mode 100644 index 0000000..665958d --- /dev/null +++ b/events/src/Events/Spec/Types.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE GADTs, DataKinds, PolyKinds, TypeOperators, KindSignatures, TypeFamilies, ExplicitNamespaces #-} + +module Events.Spec.Types + ( Expr(..) + , Val(..) + , Elem(..) + , Length(..) + , type (++)(..) + ) where + +data Expr :: (* -> *) -> [*] -> * -> * where + ELit :: Val m a -> Expr m ctx a + EVar :: Elem a ctx -> Expr m ctx a + ELam :: Expr m (arg ': ctx) res -> Expr m ctx (arg -> res) + EApp :: Expr m ctx (arg -> a) -> Expr m ctx arg -> Expr m ctx a + +type family Val m a where + Val m (a -> b) = Expr m '[a] b + Val m a = m a + +data Elem :: a -> [a] -> * where + EZ :: Elem x (x ': xs) + ES :: Elem x xs -> Elem x (y ': xs) + +data Length :: [a] -> * where + LZ :: Length '[] + LS :: Length xs -> Length (x ': xs) + +type family (xs :: [a]) ++ (ys :: [a]) :: [a] +type instance '[] ++ ys = ys +type instance (x ': xs) ++ ys = x ': (xs ++ ys) +infixr 5 ++ diff --git a/events/src/Events/Types.hs b/events/src/Events/Types.hs index 5320bb3..6a8517b 100644 --- a/events/src/Events/Types.hs +++ b/events/src/Events/Types.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving #-} module Events.Types ( TimeRange(..), rangeStart, rangeDuration , Event(..), payload, occursWithin , EvalCtx(..), ctxEvents , ObjCtx(..), objVars, objOccurs, objPayload, objCtx - , Eval + , Eval(..) , module Data.Aeson , module Data.Time.Clock , module Data.Default.Class @@ -28,6 +28,8 @@ import Events.Types.NDT (NDT, foldNDT) import Control.Monad.State.Lazy import Control.Monad.Reader +import Control.Applicative (Alternative(..)) + data TimeRange = TimeRange { _rangeStart :: UTCTime , _rangeDuration :: NominalDiffTime @@ -69,4 +71,16 @@ objCtx fObj ctx | ctx ^. objOccurs = traverseOf (objPayload . _Just) fObj ctx | otherwise = pure ctx -type Eval m a = StateT ObjCtx (NDT (ReaderT EvalCtx m)) a +newtype Eval m a = Eval { unEval :: StateT ObjCtx (NDT (ReaderT EvalCtx m)) a } + deriving ( MonadState ObjCtx + , MonadReader EvalCtx + , MonadIO + , Functor + , Applicative + , Alternative + , Monad + , MonadPlus + ) + +instance MonadTrans Eval where + lift = Eval . lift . lift . lift diff --git a/events/src/Main.hs b/events/src/Main.hs index e4b255f..410ea1d 100644 --- a/events/src/Main.hs +++ b/events/src/Main.hs @@ -22,7 +22,7 @@ import qualified Events.Types.NDT as NDT main :: IO () main = test $ do - n <- lift $ NDT.fromFoldable ([1..] :: [Integer]) + n <- Eval . lift $ NDT.fromFoldable ([1..] :: [Integer]) lower <- filter (maybe False (< fromIntegral n) <$> view (at "num" . asDouble)) <$> view ctxEvents -- objOccurs .= (n <= 5) objOccurs .= (n >= 2) -- cgit v1.2.3