{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
module Haskus.Utils.ContFlow
( ContFlow (..)
, (>::>)
, (>:-:>)
, (>:%:>)
, ContListToTuple
, ContTupleToList
, StripR
, AddR
, MultiCont (..)
)
where
import Haskus.Utils.Tuple
import Haskus.Utils.Types
newtype ContFlow (xs :: [*]) r = ContFlow (ContListToTuple xs r -> r)
type family ContListToTuple (xs :: [*]) r where
ContListToTuple xs r = ListToTuple (AddR xs r)
type family ContTupleToList t r :: [*] where
ContTupleToList t r = StripR (TupleToList t) r
type family AddR f r where
AddR '[] r = '[]
AddR (x ': xs) r = (x -> r) ': AddR xs r
type family StripR f r where
StripR '[] r = '[]
StripR ((x -> r) ': xs) r = x ': StripR xs r
StripR ((x -> w) ': xs) r =
TypeError ( 'Text "Invalid continuation return type `"
':<>: 'ShowType w ':<>: 'Text "', expecting `"
':<>: 'ShowType r ':<>: 'Text "'")
(>::>) :: ContFlow xs r -> ContListToTuple xs r -> r
{-# INLINE (>::>) #-}
(>::>) (ContFlow f) !cs = f cs
infixl 0 >::>
(>:-:>) :: ContFlow '[a] r -> (a -> r) -> r
{-# INLINE (>:-:>) #-}
(>:-:>) (ContFlow f) c = f (Single c)
infixl 0 >:-:>
(>:%:>) :: forall ts xs r.
( ReorderTuple ts (ContListToTuple xs r)
) => ContFlow xs r -> ts -> r
{-# INLINE (>:%:>) #-}
(>:%:>) (ContFlow f) !cs = f (tupleReorder cs)
infixl 0 >:%:>
class MultiCont a where
type MultiContTypes a :: [*]
toCont :: a -> ContFlow (MultiContTypes a) r
toContM :: Monad m => m a -> ContFlow (MultiContTypes a) (m r)