ioref.hs

import Control.Monad (liftM)
import Data.IORef (IORef, newIORef, modifyIORef', readIORef)
import Data.Map (Map)
import qualified Data.Map as Map

import Control.Monad.Trans.Except (ExceptT, Except, except, runExcept, mapExcept, throwE)
import Control.Monad.IO.Class (liftIO)

data IVal
  = IInt Int
  | IString String
  | IChar Char
  | IList [Ref]
  | IStruct [(String, Ref)]

data Traversal
  = Root
  | ListIndex Int Traversal
  | StructField String Traversal
  deriving (Eq, Show)

type Ref = IORef IVal
type Env = Map String Ref

type IError = String -- TODO, add more structure

type IOThrows = ExceptT IError IO
type Throws a = Either IError a

traverseRef :: Ref -> Traversal -> IOThrows Ref
traverseRef ref traversal = case traversal of
  Root             ->
    return ref
  ListIndex i trav -> do
    ival <- liftIO (readIORef ref)
    nextRef <- listLookupIndexIO ival i
    traverseRef nextRef trav
  StructField f trav -> do
    ival <- liftIO (readIORef ref)
    nextRef <- structLookupFieldIO ival f
    traverseRef nextRef trav

refTo :: IVal -> IO Ref
refTo value = newIORef value

modifyRef :: Ref -> (IVal -> IVal) -> IO ()
modifyRef reference fn = modifyIORef' reference fn

replaceRef :: Ref -> IVal -> IO ()
replaceRef reference newVal = modifyRef reference (\_ -> newVal)

structGet :: IVal -> String -> IOThrows IVal
structGet struct name = do
  field <- structLookupFieldIO struct name
  liftIO $ readIORef field

structSet :: IVal -> String -> IVal -> IOThrows ()
structSet struct name val = do
  field <- structLookupFieldIO struct name
  liftIO $ replaceRef field val

structLookupFieldIO :: IVal -> String -> IOThrows Ref
structLookupFieldIO ival name = liftEither $ structLookupField ival name

structLookupField :: IVal -> String -> Throws Ref
structLookupField (IStruct fields) name =
  case lookup name fields of
   Nothing    -> Left $ "missing field: " ++ name
   Just field -> return field
structLookupField _                 _   =
  Left "Cannot access field of non-structure"

listGet :: IVal -> Int -> IOThrows IVal
listGet list index = do
  ref <- listLookupIndexIO list index
  liftIO $ readIORef ref

listSet :: IVal -> Int -> IVal -> IOThrows ()
listSet list index val = do
  ref <- listLookupIndexIO list index
  liftIO $ replaceRef ref val

listLookupIndexIO :: IVal -> Int -> IOThrows Ref
listLookupIndexIO ival index = liftEither $ listLookupIndex ival index

liftEither :: Throws a -> IOThrows a
liftEither (Left err)  = throwE err
liftEither (Right res) = return res

listLookupIndex :: IVal -> Int -> Throws Ref
listLookupIndex (IList items) index =
  case drop index items of
   []    -> Left "Index out of bounds"
   (r:_) -> return r
listLookupIndex _ _ = Left "Cannot index into a non-list"