{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
module Haskus.Utils.ContFlow
( ContFlow (..)
, ContTuple
, (>:>)
, (>-:>)
, (>%:>)
, (>::>)
, (>:-:>)
, (>:%:>)
, ToMultiCont
, MultiCont (..)
)
where
import Haskus.Utils.Tuple
newtype ContFlow (xs :: [*]) r = ContFlow (ContTuple xs r -> r)
type family ContTuple (xs :: [*]) r where
ContTuple xs r = Tuple (ToMultiCont xs r)
type family ToMultiCont xs r where
ToMultiCont '[] r = '[]
ToMultiCont (x ': xs) r = (x -> r) ': ToMultiCont xs r
class MultiCont a where
type MultiContTypes a :: [*]
toCont :: a -> ContFlow (MultiContTypes a) r
toContM :: Monad m => m a -> ContFlow (MultiContTypes a) (m r)
(>:>) :: MultiCont a => a -> ContTuple (MultiContTypes a) r -> r
{-# INLINABLE (>:>) #-}
(>:>) a !cs = toCont a >::> cs
infixl 0 >:>
(>-:>) :: (MultiCont a, MultiContTypes a ~ '[b]) => a -> (b -> r) -> r
{-# INLINABLE (>-:>) #-}
(>-:>) a c = toCont a >:-:> c
infixl 0 >-:>
(>%:>) ::
( MultiCont a
, ReorderTuple ts (ContTuple (MultiContTypes a) r)
) => a -> ts -> r
{-# INLINABLE (>%:>) #-}
(>%:>) a !cs = toCont a >:%:> cs
infixl 0 >%:>
(>::>) :: ContFlow xs r -> ContTuple xs r -> r
{-# INLINABLE (>::>) #-}
(>::>) (ContFlow f) !cs = f cs
infixl 0 >::>
(>:-:>) :: ContFlow '[a] r -> (a -> r) -> r
{-# INLINABLE (>:-:>) #-}
(>:-:>) (ContFlow f) c = f (Unit c)
infixl 0 >:-:>
(>:%:>) :: forall ts xs r.
( ReorderTuple ts (ContTuple xs r)
) => ContFlow xs r -> ts -> r
{-# INLINABLE (>:%:>) #-}
(>:%:>) (ContFlow f) !cs = f (tupleReorder cs)
infixl 0 >:%:>