{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoMonoLocalBinds #-}
module Midair.Core (
SFlow
, sMap
, sFold
, sFoldNoDefault
, sFoldAccum
, sCompose
, sZip
, sFilter
, mkNodeRef
, SFNodeRef
, nRef
, hotSwap
, hotSwapSTM
, fireGraph
, fireGraphIO
) where
import Control.Arrow
import qualified Control.Category as Cat
import Control.Concurrent.STM
data SFlow a c where
SF_Map :: (a -> c) -> SFlow a c
SF_Compose :: forall a b c. SFlow b c -> SFlow a b -> SFlow a c
SF_FoldP :: c -> (a -> c -> c) -> SFlow a c
SF_FoldAccum :: Maybe c -> (a -> Maybe c -> c) -> SFlow a c
SF_Zip :: forall a b c. SFlow a b -> SFlow a c -> SFlow a (b, c)
SF_Filter :: Maybe a -> (a -> Bool) -> SFlow a (Maybe a)
SF_NodeRef :: TVar (Maybe c) -> TVar (SFlow a c) -> SFlow a c
data SFNodeRef a c
= SFNodeRef_Internal (TVar (Maybe c)) (TVar (SFlow a c))
nRef :: SFNodeRef a c -> SFlow a c
nRef (SFNodeRef_Internal x y) = SF_NodeRef x y
mkNodeRefSTM :: SFlow i o -> STM (SFNodeRef i o)
mkNodeRefSTM sigNode = do
sigNodeTVar <- newTVar sigNode
foo <- newTVar Nothing
return $ SFNodeRef_Internal foo sigNodeTVar
mkNodeRef :: SFlow i o -> IO (SFNodeRef i o)
mkNodeRef g = atomically $ mkNodeRefSTM g
fireGraph :: TVar (SFlow a c) -> a -> STM c
fireGraph graphTVar inVal = do
(newGraph, retVal) <- (flip fireGraph') inVal =<< readTVar graphTVar
writeTVar graphTVar newGraph
return retVal
fireGraph' :: SFlow a c -> a -> STM (SFlow a c, c)
fireGraph' m@(SF_Map f) a =
return (m, f a)
fireGraph' (SF_Compose bToCOld aToBOld) a = do
(aToBNew, rightVal) <- fireGraph' aToBOld a
(bToCNew, returnVal) <- fireGraph' bToCOld rightVal
return (SF_Compose bToCNew aToBNew, returnVal)
fireGraph' (SF_FoldP theLastVal f) a =
let newVal = f a theLastVal
in return (SF_FoldP newVal f, newVal)
fireGraph' (SF_FoldAccum theLastVal f) a =
let newVal = f a theLastVal
in return (SF_FoldAccum (Just newVal) f, newVal)
fireGraph' (SF_Zip aToBOld aToCOld) a = do
(aToBNew, b) <- fireGraph' aToBOld a
(aToCNew, c) <- fireGraph' aToCOld a
return (SF_Zip aToBNew aToCNew, (b, c))
fireGraph' (SF_Filter previousVal filterF) newVal = return $
if filterF newVal
then (SF_Filter (Just newVal) filterF, Just newVal)
else (SF_Filter previousVal filterF, previousVal)
fireGraph' (SF_NodeRef prevOutVar graphRef) newIn = do
newOut <- fireGraph graphRef newIn
writeTVar prevOutVar $ Just newOut
return (SF_NodeRef prevOutVar graphRef, newOut)
fireGraphIO :: TVar (SFlow a c) -> a -> IO c
fireGraphIO graphTVar inVal =
atomically $ fireGraph graphTVar inVal
sMap :: (a -> c) -> SFlow a c
sMap = SF_Map
sCompose :: SFlow b c -> SFlow a b -> SFlow a c
sCompose = SF_Compose
sFold :: c -> (a -> c -> c) -> SFlow a c
sFold = SF_FoldP
sFoldNoDefault :: (a -> Maybe c -> c) -> SFlow a c
sFoldNoDefault f = SF_FoldAccum Nothing f
sFoldAccum :: Maybe c -> (a -> Maybe c -> c) -> SFlow a c
sFoldAccum maybeV f = SF_FoldAccum maybeV f
sZip :: SFlow a b -> SFlow a c -> SFlow a (b, c)
sZip = SF_Zip
sFilter :: (b -> Bool) -> SFlow b (Maybe b)
sFilter f = SF_Filter Nothing f
instance Functor (SFlow a) where
fmap f0 (SF_Map f1) = SF_Map (f0 . f1)
fmap f0 sf@(SF_FoldP _ _) = SF_Compose (SF_Map f0) sf
fmap f0 sf@(SF_FoldAccum _ _) = SF_Compose (SF_Map f0) sf
fmap f0 sf@(SF_Compose _ _) = SF_Compose (SF_Map f0) sf
fmap f0 sf@(SF_Zip _ _) = SF_Compose (SF_Map f0) sf
fmap f0 sf@(SF_Filter _ _) = SF_Compose (SF_Map f0) sf
fmap f0 sf@(SF_NodeRef _ _) = SF_Compose (SF_Map f0) sf
instance Applicative (SFlow a) where
pure x = SF_Map $ \_ -> x
(<*>) a b = SF_Compose (SF_Map (\(f, x) -> f x)) (SF_Zip a b)
instance Cat.Category SFlow where
id = SF_Map $ \x -> x
(.) a b = SF_Compose a b
instance Arrow SFlow where
arr = SF_Map
first :: SFlow b c -> SFlow (b, d) (c, d)
first bToC =
sZip (bToC `sCompose` arr fst) (arr snd)
hotSwapSTM :: SFNodeRef a c -> (Maybe c -> SFlow a c) -> STM ()
hotSwapSTM (SFNodeRef_Internal oldValMaybeTVar graphTVar) newGraphFromVal = do
oldValMaybe <- readTVar oldValMaybeTVar
writeTVar graphTVar $ newGraphFromVal oldValMaybe
hotSwap :: SFNodeRef a c -> (Maybe c -> SFlow a c) -> IO ()
hotSwap a b = atomically $ hotSwapSTM a b