content: -----------------------------------------------------------------------------
  -- |
  -- Module      : Berp.Base.SemanticTypes
  -- Copyright   : (c) 2010 Bernie Pope
  -- License     : BSD-style
  -- Maintainer  : florbitous@gmail.com
  -- Stability   : experimental
  -- Portability : ghc
  --
  -- The core types used to represent the state of Python programs. We put
  -- them all here in one file because they tend to be mutually recursive.
  -- Using one file for such types tends to avoid problems with unbreakable
  -- cycles in the Haskell module imports. Try not to put functions in here
  -- (except perhaps type class instances).
  --
  -----------------------------------------------------------------------------
  
  module Berp.Base.SemanticTypes
     ( Procedure, ControlStack (..), EvalState (..), Object (..), Eval, ObjectRef
     , HashTable, HashSet, ListArray, Arity, ModuleCache
     , initState )  where
  
  import Data.Typeable (Typeable)
  import Control.Monad.State.Strict (StateT)
  import Control.Monad.Cont (ContT)
  import Data.IntMap (IntMap)
  import Data.Map as Map (Map, empty)
  import Data.IORef (IORef)
  import Data.Complex (Complex)
  import Data.Array.IO (IOArray)
  import Berp.Base.Identity (Identity)
  
  data ControlStack
     = EmptyStack
     | ProcedureCall
       { procedure_return :: Object -> Eval Object
       , control_stack_tail :: ControlStack
       }
     | ExceptionHandler
       { exception_handler :: Maybe (Object -> Eval Object)
       , exception_finally :: Maybe (Eval Object)
       , control_stack_tail :: ControlStack
       }
     | WhileLoop
       { loop_start :: Eval Object
       , loop_end :: Eval Object
       , control_stack_tail :: ControlStack
       }
     | GeneratorCall
       { generator_yield :: Object -> Eval Object
       , generator_object :: Object
       , control_stack_tail :: ControlStack
       }
  
  instance Show ControlStack where
     show EmptyStack = "EmptyStack"
     show (ProcedureCall {}) = "ProcedureCall"
     show (ExceptionHandler {}) = "ExceptionHandler"
     show (WhileLoop {}) = "WhileLoop"
     show (GeneratorCall {}) = "GeneratorCall"
  
  data EvalState =
     EvalState
     { state_control_stack :: !ControlStack
     , state_builtins :: !HashTable
     , state_moduleCache :: !ModuleCache
     }
  
  initState :: HashTable -> EvalState
  initState builtins =
     EvalState
     { state_control_stack = EmptyStack
     , state_builtins = builtins
     , state_moduleCache = Map.empty
     }
  
  type ModuleCache = Map String Object
  
  type Eval a = StateT EvalState (ContT Object IO) a
  
  type ObjectRef = IORef Object
  type Procedure = [Object] -> Eval Object
  
  -- XXX maybe this should be:
  -- IORef (IntMap (IORef [(Object, Object)]))
  -- or even:
  -- IORef (IntMap (IORef [(Object, ObjectRef)]))
  -- type HashTable = IORef (IntMap [(Object, Object)])
  
  type HashTable = IORef (IntMap [(Object, ObjectRef)])
  type HashSet = IORef (IntMap [Object])
  
  type ListArray = IOArray Integer Object
  type Arity = Int
  
  {-
  -- Here's another possible encoding of objects which is more abstract.
  -- It would make it easier to add new object types, and they could be added
  -- in separate modules. The problem is that it would make it slower for
  -- detecting the kind of object we have, compared to the Alegabraic approach
  -- which gives us a tag to match against.
  
  class ObjectLike t where
     identity :: t -> Identity
     ...
  
  data Object = forall t . (ObjectLike t, Typeable t) => O t
  
  instance ObjectLike Object where
     identity (O x) = identity x
     ...
  -}
  
  -- XXX probably need Bound Methods.
  data Object
     = Object
       { object_identity :: !Identity
       , object_type :: !Object -- type
       , object_dict :: !Object -- dictionary
       }
     | Type
       { object_identity :: !Identity
       , object_type :: Object  -- type, is this needed? Is the type of all types == type?
       , object_dict :: !Object  -- dictionary
       , object_bases :: !Object -- tuple
       , object_constructor :: !Procedure
       , object_type_name :: !Object -- string
       , object_mro :: !Object -- tuple. Method Resolution Order.
       }
     | Integer
       { object_identity :: !Identity
       , object_integer :: !Integer
       }
     | Float
       { object_identity :: !Identity
       , object_float :: !Double
       }
     | Complex
       { object_identity :: !Identity
       , object_complex :: Complex Double
       }
     | Bool
       { object_identity :: !Identity
       , object_bool :: !Bool
       }
     | Tuple
       { object_identity :: !Identity
       , object_tuple :: ![Object]
       , object_length :: !Int
       }
     -- We must allow the contents and the size of an array to change.
     | List
       { object_identity :: !Identity
       , object_list_elements :: !(IORef ListArray)
       , object_list_num_elements :: !(IORef Integer)
       }
     | Function
       { object_identity :: !Identity
       , object_procedure :: !Procedure
       , object_arity :: !Arity
       , object_dict :: !Object -- dictionary
       }
     | String
       { object_identity :: !Identity
       , object_string :: !String
       }
     | Dictionary
       { object_identity :: !Identity
       , object_hashTable :: !HashTable
       }
     | Set
       { object_identity :: !Identity
       , object_hashSet :: !HashSet
       }
     | Generator
       { object_identity :: !Identity
       , object_continuation :: !(IORef (Eval Object))
       , object_stack_context :: !(IORef (ControlStack -> ControlStack))
       }
       -- Modules probably need names and source information.
     | Module
       { object_identity :: !Identity
       , object_dict :: !Object -- dictionary
       }
     | None
  
  -- For debugging only
  instance Show Object where
     show obj@(Object {}) = "object of (" ++ show (object_type obj) ++ ")"
     show obj@(Type {}) = "type(" ++ show (object_type_name obj) ++ ")"
     show obj@(Integer {}) = "integer(" ++ show (object_integer obj) ++ ")"
     show obj@(Float {}) = "float(" ++ show (object_float obj) ++ ")"
     show obj@(Bool {}) = "bool(" ++ show (object_bool obj) ++ ")"
     show (Tuple {}) = "tuple"
     show (List {}) = "list"
     show (Function {}) = "function"
     show obj@(String {}) = "string(" ++ show (object_string obj) ++ ")"
     show (Dictionary {}) = "dictionary"
     show (Set {}) = "set"
     show (Generator {}) = "generator"
     show obj@(Complex {}) = "complex(" ++ show (object_complex obj) ++ ")"
     show (Module {}) = "module"
     show (None {}) = "None"
  
  -- equality instance for objects
  -- NOTE: use with care. This does not call the user defined equality
  -- on the object. It only uses identity equality.
  
  instance Eq Object where
     None {} == None {} = True
     obj1 == obj2 = object_identity obj1 == object_identity obj2
  