Skip to content

Instantly share code, notes, and snippets.

@valyakuttan
Created March 12, 2014 12:09
Show Gist options
  • Save valyakuttan/9505655 to your computer and use it in GitHub Desktop.
Save valyakuttan/9505655 to your computer and use it in GitHub Desktop.
Reverse State Monad example
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module StateB where
import Control.Monad.State
newtype StateB s a = StateB {runStateB :: s -> (a,s)}
instance Monad (StateB s) where
return = unitS
(>>=) = bindS
bindS :: StateB s a -> (a -> StateB s b) -> StateB s b
(StateB m) `bindS` k = StateB $ \s2 ->
let (a, s0) = m s1
(b, s1) = runStateB (k a) s2
in (b, s0)
unitS :: a -> StateB s a
unitS a = StateB $ \s -> (a, s)
execStateB :: StateB s a -> s -> s
execStateB m = snd . runStateB m
evalStateB :: StateB s a -> s -> a
evalStateB m = fst . runStateB m
modifyB :: (s -> s) -> StateB s ()
modifyB = StateB . modify'
where modify' f s = ((), f s)
atomically :: State s a -> StateB s a
atomically = StateB . runState
instance Functor (StateB s) where
fmap f m = StateB $ mapS f (runStateB m)
mapS :: (a -> b) -> (s -> (a, s)) -> s -> (b, s)
mapS f m s = let (a, s') = m s in (f a, s')
instance MonadState s (StateB s) where
get = StateB $ \s -> (s,s)
put s = StateB $ const ((),s)
instance MonadFix (StateB s) where
mfix = StateB . mfixS . (runStateB .)
mfixS :: (a -> s -> (a, s)) -> s -> (a, s)
mfixS f s2 = let (a,s0) = f b s1
(b,s1) = f a s2
in (b,s0)
module Main where
import Data.List
import Control.Monad.State
import StateB
data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)
type Table a = [a]
numberTree :: (Eq a) => Tree a -> StateB (Table a) (Tree Int)
numberTree Nil = return Nil
numberTree (Node x t1 t2)
= do num <- atomically $ numberNode x
nt1 <- numberTree t1
nt2 <- numberTree t2
return (Node num nt1 nt2)
where
numberNode :: (Eq a) => a -> State (Table a) Int
numberNode x1
= do table <- get
(newTable, newPos) <- return (nNode x1 table)
put newTable
return newPos
nNode:: (Eq a) => a -> Table a -> (Table a, Int)
nNode x1 table
= case elemIndex x1 table of
Nothing -> (table ++ [x1], length table)
Just i -> (table, i)
numTree :: (Eq a) => Tree a -> Tree Int
numTree t = evalStateB (numberTree t) []
testTree :: Tree String
testTree = Node "Zero"
(Node "One" (Node "Two" Nil Nil)
(Node "One" (Node "Three" Nil Nil) Nil)
)
Nil
main = print $ numTree testTree
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment