{-# LANGUAGE PackageImports #-}

module Control.Prototype (
	PTMonad,
	Object,
	Member,
	Method,

	runPT,
	initPTEnv,
	object,
	clone,
	makeMember,
	member,
	method,
	setMember,
	setMethod,

	liftPT,
	primInt,
	primStr,
	fromPrimInt,
	fromPrimStr,

	printMemberName,
) where

import Prelude hiding ( head )
import "monads-tf" Control.Monad.State (
	StateT, runStateT, lift, MonadIO, liftIO, modify, gets )
import Data.List ( (\\) )
import Data.Maybe ( fromMaybe, listToMaybe )

head :: a -> [ a ] -> a
head x = fromMaybe x . listToMaybe

mmap :: Monad m => ( a -> b ) -> m a -> m b
mmap f mx = mx >>= return . f

--------------------------------------------------------------------------------

type PTMonad m = StateT ( PTEnv m ) m

runPT :: Monad m => PTMonad m a -> PTEnv m -> m ( a, PTEnv m )
runPT = runStateT

liftPT :: Monad m => m a -> PTMonad m a
liftPT = lift

type PTEnv m = [ ObjectBody m ]

initPTEnv :: PTEnv m
initPTEnv = [ ObjectBody object [ ] ]

data Object =
	ObjectId { fromObjId :: Int } |
	PrimitiveInt { fromPrimInt :: Int } |
	PrimitiveString { fromPrimStr :: String }
	deriving ( Eq, Show )

primInt :: Int -> Object
primInt = PrimitiveInt

primStr :: String -> Object
primStr = PrimitiveString

object :: Object
object = ObjectId 0

data ObjectBody m =
	ObjectBody {
		objectId	:: Object,
		objectMembers	:: [ ( Member, Object ) ] } |
	Method {
		objectId	:: Object,
		objectMethod	:: Method m }

data Member = Member String deriving ( Eq, Show )
type Method m = Object -> [ Object ] -> PTMonad m [ Object ]

instance Show ( ObjectBody m ) where
	show ( Method oid _ ) = "Method " ++ show oid
	show ( ObjectBody oid st ) = "Object " ++ show oid ++ " " ++ show st

--------------------------------------------------------------------------------

getNewId :: Monad m => PTMonad m Object
getNewId = gets $
	ObjectId . head err . ( [ 1 .. ] \\ ) .	map ( fromObjId . objectId )
	where
	err = error "too many objects"

getObject :: Monad m => Object -> PTMonad m ( ObjectBody m )
getObject obj =	gets $ head err . filter ( ( == obj ) . objectId )
	where
	err = error $ "no such object: " ++ show obj

putObject :: Monad m => ObjectBody m -> PTMonad m ()
putObject = modify . ( : )

clone :: Monad m => Object -> PTMonad m Object
clone obj = do
	newId <- getNewId
	objBody <- getObject obj
	putObject $ objBody { objectId = newId }
	return newId

makeMember :: Monad m => String -> PTMonad m Member
makeMember = return . Member

member :: Monad m => Object -> Member -> PTMonad m Object
member obj mem =
	mmap ( fromMaybe err . lookup mem . objectMembers ) $ getObject obj
	where
	err = error $ "No such member: " ++ show mem ++ "\nobject: " ++ show obj

method :: Monad m => Object -> Member -> [ Object ] -> PTMonad m [ Object ]
method obj mem args =
	member obj mem >>= getObject >>= ( $ args ) . ( $ obj ) . objectMethod

setMember :: Monad m => Object -> Member -> Object -> PTMonad m ()
setMember obj mn val = do
	objBody@ObjectBody { objectMembers = mems } <- getObject obj
	putObject objBody { objectMembers = ( mn, val ) : mems }

setMethod :: Monad m => Object -> Member -> Method m -> PTMonad m ()
setMethod obj mem met = do
	newId <- getNewId
	putObject $ Method newId met
	setMember obj mem newId

printMemberName :: MonadIO m => Member -> m ()
printMemberName ( Member name ) = liftIO $ putStrLn name