module Control.Effect.Loop (Loop, loop, stepLoop,
LoopState, loop', toCPS, fromCPS,
continue, exit, continueWith, exitWith,
foreach, while, doWhile, once,
repeatLoop, iterateLoop) where
import Control.Effect
import Control.Monad (when)
import Data.Data (Typeable)
newtype Loop c e a
= Loop (forall r. (c -> r) -> (e -> r) -> (a -> r) -> r)
deriving (Typeable, Functor)
type instance Is Loop f = IsLoop f
type family IsLoop f where
IsLoop (Loop c e) = True
IsLoop f = False
loop :: EffectLoop c e l => (forall r. (c -> r) -> (e -> r) -> (a -> r) -> r) -> Effect l a
loop f = send $ Loop f
fromCPS :: Loop c e a -> LoopState c e a
fromCPS (Loop f) = f ContinueWith ExitWith Return
toCPS :: LoopState c e a -> Loop c e a
toCPS st = Loop $ \c2r e2r a2r ->
case st of
ContinueWith c -> c2r c
ExitWith e -> e2r e
Return a -> a2r a
data LoopState c e a = ContinueWith c
| ExitWith e
| Return a
deriving (Read, Show, Eq, Ord)
loop' :: EffectLoop c e l => LoopState c e a -> Effect l a
loop' = send . toCPS
stepLoop :: Effect (Loop c e :+ l) c -> (c -> Effect l e) -> Effect l e
stepLoop act cont = eliminate cont handle act
where
handle (Loop f) = f cont return id
class MemberEffect Loop (Loop c e) l => EffectLoop c e l
instance MemberEffect Loop (Loop c e) l => EffectLoop c e l
continueWith :: forall c e l a. EffectLoop c e l => c -> Effect l a
continueWith = loop' . ContinueWith
continue :: EffectLoop () e l => Effect l a
continue = continueWith ()
exitWith :: EffectLoop c e l => e -> Effect l a
exitWith = loop' . ExitWith
exit :: EffectLoop c () l => Effect l a
exit = exitWith ()
foreach :: [a] -> (a -> Effect (Loop c () :+ l) c) -> Effect l ()
foreach xs body = looper xs
where
looper [] = return ()
looper (x : xs') = stepLoop (body x) $ \_ -> looper xs'
while :: Effect l Bool -> Effect (Loop c () :+ l) c -> Effect l ()
while cond body = looper
where
looper = do
p <- cond
when p $ stepLoop body $ \_ -> looper
doWhile :: Effect (Loop a a :+ l) a -> Effect l Bool -> Effect l a
doWhile body cond = looper
where
looper = stepLoop body $ \a -> do
p <- cond
if p then looper else return a
once :: Effect (Loop a a :+ l) a -> Effect l a
once body = eliminate return handler body
where
handler (Loop f) = f return return id
repeatLoop :: Effect (Loop c e :+ l) a -> Effect l e
repeatLoop body = looper
where
looper = eliminate (const looper) handler body
handler (Loop f) = f (const looper) return id
iterateLoop :: c -> (c -> Effect (Loop c e :+ l) c) -> Effect l e
iterateLoop z body = looper z
where
looper c = stepLoop (body c) looper