{-# LANGUAGE RankNTypes #-}

{-|

Module      : Cps
Description : Continuation passing style, examples
Copyright   : © Frank Jung, 2020
License     : GPL-3

Example from [Wikibooks Continuation Passing
Style](https://en.wikibooks.org/wiki/Haskell/Continuation_passing_style)

This uses the 'Cont' Monad from the
[transformers](https://hackage.haskell.org/package/transformers) package.

Using 'callCC' is better than using return as argument it returns a suspended
 computation.

A function of type @a -> b@ would become @a -> (b -> r) -> r@ in CPS, where
@b -> r@ is the continuation.

-}

module Cps
  ( -- * Types
    CPS (..)
    -- * Custom continuation passing style (CPS)
  , toCPS
  , fromCPS
    -- * CPS Function Examples
  , addCont
  , addOne
  , pythagorasCont
  , releaseString
  , releaseStringCPS
  , squareCont
  , withOS
  , withTimestamp
  , withVersionNumber
  ) where

import           Control.Monad.Trans.Cont (Cont, callCC)

-- | Custom continuation passing style.
--
-- The following example uses a custom continuation-passing style (CPS) to
-- demonstrate the general concept.
--
-- This converts any value into a suspended computation.
--
-- @flip ($) :: b -> (b -> c) -> c@
--
-- Longhand this is:
-- @
-- toCPS a = \k -> k a
-- @
--
-- Or more simply as:
-- @
-- toCPS a k = k a
-- @
toCPS :: a -> (forall r. (a -> r) -> r)
toCPS :: forall a. a -> forall r. (a -> r) -> r
toCPS = ((a -> r) -> a -> r) -> a -> (a -> r) -> r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> r) -> a -> r
forall a b. (a -> b) -> a -> b
($)

-- | From custom continuation.
--
-- The following example calls the continuation function with 'id'.
--
-- Passing 'id' to the continuation function will return the value.
--
-- @($ id) :: ((a -> a) -> b) -> b@
--
-- Longhand this is:
-- @
-- fromCPS f = f id
-- @
fromCPS :: (forall r. (a -> r) -> r) -> a
fromCPS :: forall a. (forall r. (a -> r) -> r) -> a
fromCPS = (((a -> a) -> a) -> (a -> a) -> a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. a -> a
id)

-- | Continuation passing style (CPS) examples.
--
-- The following uses the 'Cont' Monad from the 'transformers' package.

-- | Continuation for add function.
addCont :: Int -> Int -> Cont r Int
addCont :: forall r. Int -> Int -> Cont r Int
addCont Int
x Int
y = ((Int -> ContT r Identity Int) -> ContT r Identity Int)
-> ContT r Identity Int
forall {k} a (r :: k) (m :: k -> *) b.
((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC (((Int -> ContT r Identity Int) -> ContT r Identity Int)
 -> ContT r Identity Int)
-> ((Int -> ContT r Identity Int) -> ContT r Identity Int)
-> ContT r Identity Int
forall a b. (a -> b) -> a -> b
$ \Int -> ContT r Identity Int
k -> Int -> ContT r Identity Int
k (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y)

-- | Continuation for square function.
squareCont :: Int -> Cont r Int
squareCont :: forall r. Int -> Cont r Int
squareCont Int
x = ((Int -> ContT r Identity Int) -> ContT r Identity Int)
-> ContT r Identity Int
forall {k} a (r :: k) (m :: k -> *) b.
((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC (((Int -> ContT r Identity Int) -> ContT r Identity Int)
 -> ContT r Identity Int)
-> ((Int -> ContT r Identity Int) -> ContT r Identity Int)
-> ContT r Identity Int
forall a b. (a -> b) -> a -> b
$ \Int -> ContT r Identity Int
k -> Int -> ContT r Identity Int
k (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
x)

-- | Continuation for pythagoras function.
pythagorasCont :: Int -> Int -> Cont r Int
pythagorasCont :: forall r. Int -> Int -> Cont r Int
pythagorasCont Int
x Int
y = do
    Int
x_squared <- Int -> Cont r Int
forall r. Int -> Cont r Int
squareCont Int
x
    Int
y_squared <- Int -> Cont r Int
forall r. Int -> Cont r Int
squareCont Int
y
    Int -> Int -> Cont r Int
forall r. Int -> Int -> Cont r Int
addCont Int
x_squared Int
y_squared

-- | Type CPS for Continuation-passing style.
--
-- See CpsSpec.hs for usage.
newtype CPS a = CPS { forall a. CPS a -> forall r. (a -> r) -> r
runCPS :: forall r. (a -> r) -> r}

-- | Functor instance for 'CPS'.
instance Functor CPS where
  fmap :: forall a b. (a -> b) -> CPS a -> CPS b
fmap a -> b
f (CPS forall r. (a -> r) -> r
g) = (forall r. (b -> r) -> r) -> CPS b
forall a. (forall r. (a -> r) -> r) -> CPS a
CPS ((forall r. (b -> r) -> r) -> CPS b)
-> (forall r. (b -> r) -> r) -> CPS b
forall a b. (a -> b) -> a -> b
$ \b -> r
k -> (a -> r) -> r
forall r. (a -> r) -> r
g (b -> r
k (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- | Application instance for 'CPS'.
instance Applicative CPS where
  pure :: forall a. a -> CPS a
pure a
a = (forall r. (a -> r) -> r) -> CPS a
forall a. (forall r. (a -> r) -> r) -> CPS a
CPS ((a -> r) -> a -> r
forall a b. (a -> b) -> a -> b
$ a
a)
  (CPS forall r. ((a -> b) -> r) -> r
f) <*> :: forall a b. CPS (a -> b) -> CPS a -> CPS b
<*> (CPS forall r. (a -> r) -> r
g) = (forall r. (b -> r) -> r) -> CPS b
forall a. (forall r. (a -> r) -> r) -> CPS a
CPS ((forall r. (b -> r) -> r) -> CPS b)
-> (forall r. (b -> r) -> r) -> CPS b
forall a b. (a -> b) -> a -> b
$ \b -> r
k -> ((a -> b) -> r) -> r
forall r. ((a -> b) -> r) -> r
f (\a -> b
a -> (a -> r) -> r
forall r. (a -> r) -> r
g (b -> r
k (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
a))

-- | Monad instance for 'CPS'.
instance Monad CPS where
  -- return a = CPS ($ a)
  (CPS forall r. (a -> r) -> r
g) >>= :: forall a b. CPS a -> (a -> CPS b) -> CPS b
>>= a -> CPS b
f = (forall r. (b -> r) -> r) -> CPS b
forall a. (forall r. (a -> r) -> r) -> CPS a
CPS ((forall r. (b -> r) -> r) -> CPS b)
-> (forall r. (b -> r) -> r) -> CPS b
forall a b. (a -> b) -> a -> b
$ \b -> r
k -> (a -> r) -> r
forall r. (a -> r) -> r
g (\a
a -> CPS b -> forall r. (b -> r) -> r
forall a. CPS a -> forall r. (a -> r) -> r
runCPS (a -> CPS b
f a
a) b -> r
k)

-- Define a simple function to apply
addOne :: Int -> Int
addOne :: Int -> Int
addOne Int
x = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- | Returns (fixed) version.
withVersionNumber :: (Double -> r) -> r
withVersionNumber :: forall r. (Double -> r) -> r
withVersionNumber Double -> r
f = Double -> r
f Double
0.1

-- | Returns (fixed) timestamp.
withTimestamp :: (Int -> r) -> r
withTimestamp :: forall r. (Int -> r) -> r
withTimestamp Int -> r
f = Int -> r
f Int
1532083362

-- | Returns (fixed) OS.
withOS :: (String -> r) -> r
withOS :: forall r. (String -> r) -> r
withOS String -> r
f = String -> r
f String
"linux"

-- | Return version, timestamp and OS as pyramid of doom.
releaseString :: String
releaseString :: String
releaseString =
  (String -> String) -> String
forall r. (String -> r) -> r
withOS ((String -> String) -> String) -> (String -> String) -> String
forall a b. (a -> b) -> a -> b
$ \String
os ->
    (Double -> String) -> String
forall r. (Double -> r) -> r
withVersionNumber ((Double -> String) -> String) -> (Double -> String) -> String
forall a b. (a -> b) -> a -> b
$ \Double
version ->
      (Int -> String) -> String
forall r. (Int -> r) -> r
withTimestamp ((Int -> String) -> String) -> (Int -> String) -> String
forall a b. (a -> b) -> a -> b
$ \Int
timestamp ->
        String
os String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
timestamp

-- | Return version, timestamp and OS using the 'CPS' type.
releaseStringCPS :: CPS String
releaseStringCPS :: CPS String
releaseStringCPS = do
  String
os <- (forall r. (String -> r) -> r) -> CPS String
forall a. (forall r. (a -> r) -> r) -> CPS a
CPS (String -> r) -> r
forall r. (String -> r) -> r
withOS
  Double
version <- (forall r. (Double -> r) -> r) -> CPS Double
forall a. (forall r. (a -> r) -> r) -> CPS a
CPS (Double -> r) -> r
forall r. (Double -> r) -> r
withVersionNumber
  Int
timestamp <- (forall r. (Int -> r) -> r) -> CPS Int
forall a. (forall r. (a -> r) -> r) -> CPS a
CPS (Int -> r) -> r
forall r. (Int -> r) -> r
withTimestamp
  String -> CPS String
forall a. a -> CPS a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> CPS String) -> String -> CPS String
forall a b. (a -> b) -> a -> b
$ String
os String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
timestamp