{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}

-- | Continuation based control-flow
module Haskus.Utils.ContFlow
   ( ContFlow (..)
   , ContTuple
   , (>:>)
   , (>-:>)
   , (>%:>)
   , (>::>)
   , (>:-:>)
   , (>:%:>)
   , ToMultiCont
   , MultiCont (..)
   )
where

import Haskus.Utils.Tuple
import Haskus.Utils.Types

-- | A continuation based control-flow
newtype ContFlow (xs :: [Type]) r = ContFlow (ContTuple xs r -> r)

-- | Convert a list of types into the actual data type representing the
-- continuations.
type family ContTuple (xs :: [Type]) 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

-- | A multi-continuable type
class MultiCont a where
   type MultiContTypes a :: [Type]

   -- | Convert a data into a multi-continuation
   toCont :: a -> ContFlow (MultiContTypes a) r

   -- | Convert a data into a multi-continuation (monadic)
   toContM :: Monad m => m a -> ContFlow (MultiContTypes a) (m r)


-- | Bind a multi-continuable type to a tuple of continuations
(>:>) :: MultiCont a => a -> ContTuple (MultiContTypes a) r -> r
{-# INLINABLE (>:>) #-}
>:> :: forall a r. MultiCont a => a -> ContTuple (MultiContTypes a) r -> r
(>:>) a
a !ContTuple (MultiContTypes a) r
cs = a -> ContFlow (MultiContTypes a) r
forall r. a -> ContFlow (MultiContTypes a) r
forall a r. MultiCont a => a -> ContFlow (MultiContTypes a) r
toCont a
a ContFlow (MultiContTypes a) r
-> ContTuple (MultiContTypes a) r -> r
forall (xs :: [*]) r. ContFlow xs r -> ContTuple xs r -> r
>::> ContTuple (MultiContTypes a) r
cs

infixl 0 >:>

-- | Bind a single-continuable type to a 1-tuple of continuations
(>-:>) :: (MultiCont a, MultiContTypes a ~ '[b]) => a -> (b -> r) -> r
{-# INLINABLE (>-:>) #-}
>-:> :: forall a b r.
(MultiCont a, MultiContTypes a ~ '[b]) =>
a -> (b -> r) -> r
(>-:>) a
a b -> r
c = a -> ContFlow (MultiContTypes a) r
forall r. a -> ContFlow (MultiContTypes a) r
forall a r. MultiCont a => a -> ContFlow (MultiContTypes a) r
toCont a
a ContFlow '[b] r -> (b -> r) -> r
forall a r. ContFlow '[a] r -> (a -> r) -> r
>:-:> b -> r
c

infixl 0 >-:>

-- | Bind a multi-continuable type to a tuple of continuations and
-- reorder fields if necessary
(>%:>) ::
   ( MultiCont a
   , ReorderTuple ts (ContTuple (MultiContTypes a) r)
   ) => a -> ts -> r
{-# INLINABLE (>%:>) #-}
>%:> :: forall a ts r.
(MultiCont a, ReorderTuple ts (ContTuple (MultiContTypes a) r)) =>
a -> ts -> r
(>%:>) a
a !ts
cs = a -> ContFlow (MultiContTypes a) r
forall r. a -> ContFlow (MultiContTypes a) r
forall a r. MultiCont a => a -> ContFlow (MultiContTypes a) r
toCont a
a ContFlow (MultiContTypes a) r -> ts -> r
forall ts (xs :: [*]) r.
ReorderTuple ts (ContTuple xs r) =>
ContFlow xs r -> ts -> r
>:%:> ts
cs

infixl 0 >%:>


-- | Bind a flow to a tuple of continuations
(>::>) :: ContFlow xs r -> ContTuple xs r -> r
{-# INLINABLE (>::>) #-}
>::> :: forall (xs :: [*]) r. ContFlow xs r -> ContTuple xs r -> r
(>::>) (ContFlow ContTuple xs r -> r
f) !ContTuple xs r
cs = ContTuple xs r -> r
f ContTuple xs r
cs

infixl 0 >::>

-- | Bind a flow to a 1-tuple of continuations
(>:-:>) :: ContFlow '[a] r -> (a -> r) -> r
{-# INLINABLE (>:-:>) #-}
>:-:> :: forall a r. ContFlow '[a] r -> (a -> r) -> r
(>:-:>) (ContFlow ContTuple '[a] r -> r
f) a -> r
c = ContTuple '[a] r -> r
f ((a -> r) -> Solo (a -> r)
forall a. a -> Solo a
Solo a -> r
c)

infixl 0 >:-:>

-- | Bind a flow to a tuple of continuations and
-- reorder fields if necessary
(>:%:>) :: forall ts xs r.
   ( ReorderTuple ts (ContTuple xs r)
   ) => ContFlow xs r -> ts -> r
{-# INLINABLE (>:%:>) #-}
>:%:> :: forall ts (xs :: [*]) r.
ReorderTuple ts (ContTuple xs r) =>
ContFlow xs r -> ts -> r
(>:%:>) (ContFlow ContTuple xs r -> r
f) !ts
cs = ContTuple xs r -> r
f (ts -> Tuple (ToMultiCont xs r)
forall t1 t2. ReorderTuple t1 t2 => t1 -> t2
tupleReorder ts
cs)

infixl 0 >:%:>