Unsafely Inspecting Monadic Computations

Main.purs

module Main where

import Prelude

import Data.Set as S
import Data.Array
import Data.Lazy
import Data.Maybe
import Data.Tuple

import Control.Monad.Eff (Eff)
import Control.Monad.Writer

import Unsafe.Coerce (unsafeCoerce)

import TryPureScript (DOM, h1, h2, p, text, list, indent, link, render, code)

-- the cheat:

undef :: forall a. a
undef = unsafeCoerce "oops!"

-- Program 1 - inspecting gets and puts as Set/StrMap

prog1 :: forall f r a.
         Monad f =>
         { get :: String -> f a
         , put :: String -> a -> f Unit | r } ->
         a -> f (Array a)
prog1 k mouse = do
   f <- k.get "Cats"
   s <- k.get "Dogs"
   k.put "Mice" mouse
   t <- k.get "Cats"
   pure [f, s, t]

get1 :: forall a. String -> Writer (Tuple (S.Set String) (S.Set (Tuple String Int))) a
get1 key = writer (Tuple undef (Tuple (S.singleton key) (S.empty)))

put1 :: forall a. String -> Int -> Writer (Tuple (S.Set String) (S.Set (Tuple String Int))) a
put1 key value = writer (Tuple undef (Tuple (S.empty) (S.singleton (Tuple key value))))

inspect1 :: (Tuple (S.Set String) (S.Set (Tuple String Int)))
inspect1 = snd $ runWriter $ prog1 {get:get1, put:put1} 1

inspect1_unsafe :: Array Int
inspect1_unsafe = fst $ runWriter $ prog1 {get:get1, put:put1} 1

-- Program 2 - Laziness

prog2_strict :: forall f r a.
                Monad f =>
                { get :: String -> f (Maybe a)
                , put :: String -> a -> f Unit | r } ->
                a -> f (Array a)
prog2_strict k mouse = do
   f <- k.get "Cats"
   s <- k.get "Dogs"
   k.put "Mice" mouse
   t <- k.get "Cats"
   pure (catMaybes [f, s, t])

prog2_lazy :: forall f r a.
              Monad f =>
              { get :: String -> f (Maybe a)
              , put :: String -> a -> f Unit | r } ->
              a -> f (Lazy (Array a))
prog2_lazy k mouse = do
   f <- k.get "Cats"
   s <- k.get "Dogs"
   k.put "Mice" mouse
   t <- k.get "Cats"
   pure (defer (\_ -> catMaybes [f, s, t]))

-- uncomment and open console to see crash
--inspect2_strict :: (Tuple (S.Set String) (S.Set (Tuple String Int)))
--inspect2_strict = snd $ runWriter $ prog2_strict {get:get1, put:put1} 1

inspect2_lazy :: (Tuple (S.Set String) (S.Set (Tuple String Int)))
inspect2_lazy = snd $ runWriter $ prog2_lazy {get:get1, put:put1} 1

-- Program 3 - inspecting gets and puts as Set/Set

prog3 :: forall f r a.
         Monad f =>
         { get :: String -> f a
         , put :: String -> a -> f Unit | r } ->
         f (Array a)
prog3 k = do
   f <- k.get "Cats"
   s <- k.get "Dogs"
   k.put "Mice" f
   t <- k.get "Cats"
   pure [f, s, t]

get2 :: forall a. String -> Writer (Tuple (S.Set String) (S.Set String)) a
get2 key = writer (Tuple undef (Tuple (S.singleton key) (S.empty)))

put2 :: forall a. String -> Int -> Writer (Tuple (S.Set String) (S.Set String)) a
put2 key value = writer (Tuple undef (Tuple (S.empty) (S.singleton key)))

inspect3 :: (Tuple (S.Set String) (S.Set String))
inspect3 = snd $ runWriter $ prog3 {get:get2, put:put2}

-- Program 4 - turn off logging and inspecting

prog4 :: forall f r a.
         Monad f =>
         Show a =>
         { get :: String -> f a
         , put :: String -> a -> f Unit
         , log :: String -> f Unit | r } ->
         a -> f (Array a)
prog4 k mouse = do
   f <- k.get "Cats"
   k.log ("Cats: " <> show f)
   s <- k.get "Dogs"
   k.log ("Dogs: " <> show s)
   k.put "Mice" mouse
   t <- k.get "Cats"
   k.log ("Cats: " <> show t)
   pure [f, s, t]

log1 :: forall f a. Applicative f => String -> f a
log1 s = pure undef

inspect4 :: (Tuple (S.Set String) (S.Set (Tuple String Int)))
inspect4 = snd $ runWriter $ prog4 {get:get1, put:put1, log:log1} 1

-- mismatched handler and computation

inspect3_mismatched :: (Tuple (S.Set String) (S.Set (Tuple String Int)))
inspect3_mismatched = snd $ runWriter $ prog3 {get:get1, put:put1}

-- output

main :: Eff _ Unit
main = render $ fold
      [ h1 (text "Output:")
      , h2 (text $ "inspect prog1: ")
      , p (text $ show inspect1)
      , h2 (text $ "'run' prog1 (unsafe): ")
      , p (text $ show inspect1_unsafe)
      , h2 (text $ "inspect lazy prog2: ")
      , p (text $ show inspect2_lazy)
      , h2 (text $ "inspect prog3: ")
      , p (text $ show inspect3)
      , h2 (text $ "inspect prog4: ")
      , p (text $ show inspect4)
      , h2 (text $ "inspect progx: ")
      , p (text $ show inspect3_mismatched)
      ]