{-# LANGUAGE PackageImports #-}

module Control.Prototype (
	Prot,
	ProtEnv,
	Object,
	Member,
	Method,

	runProt,
	initProtEnv,
	package,
	object,
	clone,
	makeMember,
	setMember,
	member,
	setMethod,
	method,

	liftProt,
	primInt,
	primStr,
	fromPrimInt,
	fromPrimStr,

	printMember,
) where

import Prelude hiding ( head )
import "monads-tf" Control.Monad.State (
	StateT, runStateT, lift, MonadIO, liftIO, put, get, 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 Prot m = StateT ( ProtEnv m ) m

runProt :: Monad m => Prot m a -> ProtEnv m -> m ( a, ProtEnv m )
runProt = runStateT

liftProt :: Monad m => m a -> Prot m a
liftProt = lift

data ProtEnv m = ProtEnv {
	packageName	:: String,
	objectBodys	:: [ ObjectBody m ]
 } deriving Show

initProtEnv :: ProtEnv m
initProtEnv = ProtEnv {
	packageName	= "main",
	objectBodys	= [ 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 ] -> Prot 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 => Prot m Object
getNewId = gets $ ObjectId . head err . ( [ 1 .. ] \\ ) .
	map ( fromObjId . objectId ) . objectBodys
	where
	err = error "too many objects"

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

putObject :: Monad m => ObjectBody m -> Prot m ()
putObject objBody = do
	env@ProtEnv { objectBodys = obs } <- get
	put env { objectBodys = objBody : obs }

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

makeMember :: Monad m => String -> Prot m Member
makeMember name =
	mmap ( Member . ( ++ name ) . ( ++ "::" ) ) $ gets packageName

member :: Monad m => Object -> Member -> Prot 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 ] -> Prot m [ Object ]
method obj mem args =
	member obj mem >>= getObject >>= ( $ args ) . ( $ obj ) . objectMethod

setMember :: Monad m => Object -> Member -> Object -> Prot 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 -> Prot m ()
setMethod obj mem met = do
	newId <- getNewId
	putObject $ Method newId met
	setMember obj mem newId

package :: Monad m => String -> Prot m a -> Prot m a
package pkg act = do
	env0@ProtEnv { packageName = oldPkg } <- get
	put env0 { packageName = pkg }
	ret <- act
	env1 <- get
	put env1 { packageName = oldPkg }
	return ret

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