Monad/ST

st-monad.hs

#!/usr/bin/env nix-shell
#!nix-shell --pure -p "haskellPackages.ghcWithPackages(pkgs:[pkgs.text pkgs.bytestring])" -i runghc

{- |
Linked list using ST Monad
This is based on @Evgenity work, https://www.youtube.com/watch?v=MJscn-m4KIo
-}

{-#language RecordWildCards #-}

import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef, modifySTRef)
import Control.Monad.ST (runST, ST)
import Control.Monad (forM_)
import Data.Maybe (fromJust, isNothing)
import GHC.Generics

main :: IO ()
main = do
  putStrLn $ "hello stmonad"
  let myList = mkList
  let int = runST $ toList myList
  putStrLn $ show int

{- |
s : is the state of each thread of execution
a : is the value stored
-}
data Llist s a = Llist{llen:: STRef s Int, lhead :: STRef s (Maybe (Node s a)) }

data Node s a = Node { val :: STRef s a, next :: STRef s (Maybe (Node s a)) }

empty :: ST s (Llist s a)
empty = Llist <$> newSTRef 0 <*> newSTRef Nothing

prepend :: a -> Llist s a -> ST s ()
prepend a Llist{llen, lhead} = do
  ln <- readSTRef llen
  newnode <-readSTRef lhead  >>= \x -> Node <$> newSTRef a <*> newSTRef x
  modifySTRef llen (+1)
  writeSTRef lhead (Just newnode)

toList :: ST s (Llist s a) -> ST s [a]
toList sl = do
  Llist{llen, lhead} <- sl
  ln <- readSTRef llen
  nref <- readSTRef lhead
  if ln == 0 then return [] else go $ fromJust nref
    where
      go :: Node s a -> ST s [a]
      go (Node vr nr) = do
        nr' <- readSTRef nr
        vr' <- readSTRef vr
        case nr' of
          Nothing -> pure [vr']
          Just n ->  (vr':) <$> go n

mkList :: ST s (Llist s Integer)
mkList = do
  l <- empty
  forM_ [1 .. 10] (flip prepend l)
  -- insert l 2 (-1)
  delete l 1
  delete l 3
  delete l 7
  update l 0 100
  pure l

get_ :: Llist s a -> Int -> ST s (Either String (Node s a))
get_ Llist{llen, lhead} i
  | i <0  =  pure $ Left "index may not be negative"
  | otherwise = do
      ln <- readSTRef llen
      if i>=ln then
        pure $ Left $ "index: " <> show i <> " is greater than lenght: " <> show ln
      else
        readSTRef lhead >>= go i . fromJust
      where
          go 0 n  = pure $ Right n
          go c n = readSTRef (next n) >>= go (c-1) . fromJust

get :: Llist s a -> Int -> ST s a
get l i = do
  es <- get_ l i
  case es of
    Left s -> error s
    Right (Node {val, next}) -> readSTRef val >>= pure

insert :: Llist s a -> Int -> a -> ST s ()
insert l 0 v = prepend v l
insert l@Llist{llen} i v = do
  modifySTRef llen (+1)
  eref <- get_ l (i-1)
  case eref of
    Left e -> error e
    Right (node@Node {val, next}) -> do
      oPtr <- readSTRef next
      nNode <- Node <$> newSTRef v <*> newSTRef oPtr
      writeSTRef next ( (Just nNode))

delete :: Llist s a -> Int -> ST s ()
delete l@Llist{llen, lhead} i = do
  modifySTRef llen (\x -> x-1)
  eref <- get_ l (i-1)
  case eref of
    Left e -> error e
    Right (node@Node {val, next}) -> do
      nPtr <- readSTRef next
      case nPtr of
        Nothing -> writeSTRef next Nothing
        Just (Node val' next') ->
          readSTRef next' >>= writeSTRef next

update :: Llist s a -> Int -> a -> ST s ()
update l@Llist{llen, lhead} i a = do
  eref <- get_ l i
  case eref of
    Left e -> error e
    Right (node@Node {val, next}) -> do
      writeSTRef val a

This is a nix script. To execute:

chmod 755 ./st-monad.hs
./st-monad.hs