Lambda calculus for computing events at runtime

7 files changed, 125 insertions, 16 deletions

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)