{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Control.Funflow.Base where
import Control.Arrow (Kleisli (..))
import Control.Arrow.Free
import Control.Exception.Safe (SomeException)
import Control.Funflow.ContentHashable
import qualified Control.Funflow.ContentStore as CS
import Control.Funflow.Diagram
import Control.Funflow.External
import Data.ByteString (ByteString)
import Data.Default
import Data.Functor.Identity
import Data.Int (Int64)
import Data.Proxy (Proxy (..))
import qualified Data.Store as Store
import qualified Data.Text as T
import Path
import Prelude hiding (id, (.))
import System.Random (randomIO)
type MDWriter i o = Maybe (i -> o -> [(T.Text, ByteString)])
data Cacher i o =
NoCache
| Cache
{
cacherKey :: Int -> i -> ContentHash
, cacherStoreValue :: o -> ByteString
, cacherReadValue :: ByteString -> o
}
defaultCacherWithIdent :: (Store.Store o, ContentHashable Identity i)
=> Int
-> Cacher i o
defaultCacherWithIdent ident = Cache
{ cacherKey = \i ident' -> runIdentity $ contentHash (ident', ident, i)
, cacherStoreValue = Store.encode
, cacherReadValue = Store.decodeEx
}
data Properties i o = Properties
{
name :: Maybe T.Text
, cache :: Cacher i o
, mdpolicy :: MDWriter i o
}
instance Default (Properties i o) where
def = Properties
{ name = Nothing
, cache = NoCache
, mdpolicy = Nothing
}
data EpPurity = EpPure | EpImpure (IO Int64)
instance Default EpPurity where
def = EpPure
alwaysRecompile :: EpPurity
alwaysRecompile = EpImpure randomIO
data ExternalProperties a = ExternalProperties
{
ep_mdpolicy :: MDWriter a ()
, ep_impure :: EpPurity
}
instance Default (ExternalProperties a) where
def = ExternalProperties
{ ep_mdpolicy = Nothing
, ep_impure = def
}
data Flow' eff a b where
Step :: Properties a b -> (a -> b) -> Flow' eff a b
StepIO :: Properties a b -> (a -> IO b) -> Flow' eff a b
External :: ExternalProperties a
-> (a -> ExternalTask)
-> Flow' eff a CS.Item
PutInStore :: ContentHashable IO a => (Path Abs Dir -> a -> IO ()) -> Flow' eff a CS.Item
GetFromStore :: (Path Abs t -> IO a) -> Flow' eff (CS.Content t) a
InternalManipulateStore :: (CS.ContentStore -> a -> IO b)
-> Flow' eff a b
Wrapped :: Properties a b -> eff a b -> Flow' eff a b
type Flow eff ex = ErrorChoice ex (Flow' eff)
data NoEffect a b
runNoEffect :: forall arr. NoEffect ~> arr
runNoEffect = error "Impossible!"
type SimpleFlow = Flow NoEffect SomeException
type (==>) = SimpleFlow
toDiagram :: Flow eff ex a b -> Diagram ex a b
toDiagram = eval toDiagram' where
toDiagram' (Step (name -> Just n) f) = node f [n]
toDiagram' (StepIO (name -> Just n) f) = node (Kleisli f) [n]
toDiagram' _
= Node emptyNodeProperties (Proxy :: Proxy a1) (Proxy :: Proxy b1)