content: module Hython.Types
  where
  
  import Prelude hiding (mod)
  
  import Control.Monad (forM_, zipWithM)
  import Control.Monad.IO.Class (MonadIO, liftIO)
  import Data.ByteString (ByteString)
  import qualified Data.Hashable as H
  import qualified Data.ByteString.Char8 as B
  import Data.Complex (Complex, realPart, imagPart)
  import Data.IntMap.Strict (IntMap)
  import qualified Data.IntMap as IntMap
  import Data.List (intercalate)
  import Data.Text (Text)
  import qualified Data.Text as T
  import Data.UUID (UUID)
  import Data.UUID.V4 (nextRandom)
  
  import Language.Python (Statement)
  
  import qualified Hython.AttributeDict as AD
  import Hython.ControlFlow (MonadFlow)
  import Hython.Environment (Environment)
  import Hython.Name
  import Hython.Ref
  
  data Object = None
              | Bool Bool
              | Bytes ByteString
              | Float Double
              | Imaginary (Complex Double)
              | Int Integer
              | String Text
              | List ListRef
              | Dict DictRef
              | Set SetRef
              | BuiltinFn Text
              | Function Text [FnParam] [Statement] Env
              | Method Text MethodBinding [FnParam] [Statement] Env
              | Class ClassInfo
              | Object ObjectInfo
              | Lambda [FnParam] Statement Env
              | Module ModuleInfo
  
  type ObjectRef = Ref Object
  
  data MethodBinding = ClassBinding Text Object
                     | InstanceBinding Text Object
  
  data FnParam = NamedParam Text
               | DefParam Text Object
               | SParam Text
               | DSParam Text
  
  data ClassInfo = ClassInfo
                 { classId        :: UUID
                 , className      :: Text
                 , classModule    :: ModuleInfo
                 , classBases     :: [ClassInfo]
                 , classDict      :: Ref AttributeDict
                 }
  
  instance Eq ClassInfo where
      l == r = className l == className r
  
  data ObjectInfo = ObjectInfo
                  { objectId      :: UUID
                  , objectClass   :: ClassInfo
                  , objectDict    :: Ref AttributeDict
                  }
  
  data ModuleInfo = ModuleInfo
                  { moduleId      :: UUID
                  , moduleName    :: Text
                  , modulePath    :: FilePath
                  , moduleDict    :: Ref AttributeDict
                  }
  
  type DictRef    = Ref (IntMap (Object, Object))
  type ListRef    = Ref [Object]
  type SetRef     = Ref (IntMap Object)
  
  type AttributeDict = AD.AttributeDict Object
  
  type Env = Environment Object
  
  data ExceptionHandler = ExceptionHandler Name ClassInfo [Statement]
  
  instance Eq ModuleInfo where
      l == r = modulePath l == modulePath r
  
  class HasAttributes a where
      getObjAttrs :: a -> Maybe (Ref AttributeDict)
  
  instance HasAttributes Object where
      getObjAttrs (Object info)   = Just $ objectDict info
      getObjAttrs (Class info)    = Just $ classDict info
      getObjAttrs (Module info)   = Just $ moduleDict info
      getObjAttrs _ = Nothing
  
  class (MonadFlow Object (Object -> m ()) m, MonadIO m) => MonadInterpreter m where
      evalBlock           :: [Statement] -> m ()
      invoke              :: Object -> String -> [Object] -> m Object
      new                 :: String -> [Object] -> m Object
      pushEvalResult      :: String -> m ()
      raise               :: String -> String -> m ()
      getCurrentModule    :: m ModuleInfo
      getModuleByPath     :: FilePath -> m (Maybe ModuleInfo)
      setCurrentModule    :: ModuleInfo -> m ()
  
  hash :: MonadInterpreter m => Object -> m Int
  hash obj = case obj of
      (None)          -> return 0
      (Bool b)        -> return $ H.hash b
      (BuiltinFn b)   -> return $ H.hash b
      (Bytes b)       -> return $ H.hash b
      (Float d)       -> return $ H.hash d
      (Imaginary i)   -> return $ H.hash (realPart i) + H.hash (imagPart i)
      (Int i)         -> return $ H.hash i
      (String s)      -> return $ H.hash s
      (Object {}) -> do
          result <- invoke obj "__hash__" []
          case result of
              (Int i) -> return $ fromInteger i
              _       -> do
                  raise "SystemError" "non-int returned from __hash__"
                  return 0
      _               -> do
          raise "TypeError" "unhashable type"
          return 0
  
  newNone :: MonadInterpreter m => m Object
  newNone = return None
  
  newBool :: MonadInterpreter m => Bool -> m Object
  newBool b = return $ Bool b
  
  newBytes :: MonadInterpreter m => String -> m Object
  newBytes b = return $ Bytes (B.pack b)
  
  newClass :: (MonadIO m) => Text -> [ClassInfo] -> [(Text, ObjectRef)] -> ModuleInfo -> m Object
  newClass name bases dict mod = do
      ref     <- newRef $ AD.fromList dict
      clsid   <- liftIO nextRandom
  
      return . Class $ ClassInfo {
          classId = clsid,
          className = name,
          classBases = bases,
          classDict = ref,
          classModule = mod
      }
  
  newDict :: MonadInterpreter m => [(Object, Object)] -> m Object
  newDict items = do
      dict <- new "dict" []
      forM_ items $ \(key, value) ->
          invoke dict "__setitem__" [key, value]
      return dict
  
  newFloat :: MonadInterpreter m => Double -> m Object
  newFloat d = return $ Float d
  
  newFunction :: MonadInterpreter m => Text -> [FnParam] -> [Statement] -> Env -> m Object
  newFunction name params block env = return $ Function name params block env
  
  newImag :: MonadInterpreter m => Complex Double -> m Object
  newImag i = return $ Imaginary i
  
  newInt :: MonadInterpreter m => Integer -> m Object
  newInt i = return $ Int i
  
  newLambda :: Monad m => [FnParam] -> Statement -> Env -> m Object
  newLambda params statement env = return $ Lambda params statement env
  
  newList :: (MonadInterpreter m, MonadIO m) => [Object] -> m Object
  newList items = do
      list <- new "list" []
      mapM_ (\item -> invoke list "append" [item]) items
      return list
  
  newModule :: MonadIO m => Text -> FilePath -> m Object
  newModule name path = do
      ref     <- newRef AD.empty
      modid   <- liftIO nextRandom
  
      return . Module $ ModuleInfo
          { moduleId = modid
          , moduleName = name
          , modulePath = path
          , moduleDict = ref
          }
  
  newObject :: (MonadIO m) => ClassInfo -> m Object
  newObject cls = do
      clsDict <- readRef . classDict $ cls
      dict    <- newRef clsDict
      objid   <- liftIO nextRandom
  
      return . Object $ ObjectInfo
          { objectId = objid
          , objectClass = cls
          , objectDict = dict
          }
  
  newSet :: MonadInterpreter m => [Object] -> m Object
  newSet items = do
      set <- new "set" []
      mapM_ (\item -> invoke set "add" [item]) items
      return set
  
  newString :: MonadInterpreter m => Text -> m Object
  newString s = return $ String s
  
  newTuple :: MonadInterpreter m => [Object] -> m Object
  newTuple items = do
      args    <- newList items
      new "tuple" [args]
  
  isNone :: Object -> Bool
  isNone (None) = True
  isNone _ = False
  
  equal :: MonadInterpreter m => Object -> Object -> m Bool
  equal lhs rhs = case (lhs, rhs) of
      -- conversion
      (Bool l, _) -> equal (Float (boolToFloat  l)) rhs
      (Int  l, _) -> equal (Float (fromIntegral l)) rhs
      (_, Bool r) -> equal lhs (Float (boolToFloat  r))
      (_, Int  r) -> equal lhs (Float (fromIntegral r))
      (None,        None       ) -> return True
      (Bytes     l, Bytes     r) -> return $ l == r
      (Float     l, Float     r) -> return $ l == r
      (Imaginary l, Imaginary r) -> return $ l == r
      (String    l, String    r) -> return $ l == r
      (BuiltinFn l, BuiltinFn r) -> return $ l == r
      (Dict      l, Dict      r) -> do
          left    <- readRef l
          right   <- readRef r
          if IntMap.size left /= IntMap.size right
              then return False
              else do
                  results <- zipWithM pairEqual (IntMap.elems left) (IntMap.elems right)
                  return $ all (== True) results
      (_, _) -> return False
    where
      boolToFloat False = 0.0
      boolToFloat True  = 1.0
      pairEqual (lk, lv) (rk, rv) = do
          k <- equal lk rk
          v <- equal lv rv
          return $ k && v
  
  isTruthy :: MonadInterpreter m => Object -> m Bool
  isTruthy (None) = return False
  isTruthy (Bool False) = return False
  isTruthy (Int 0) = return False
  isTruthy (Float 0.0) = return False
  isTruthy (String s) = return . not . T.null $ s
  isTruthy (Bytes b) = return $ not (B.null b)
  isTruthy (List ref) = do
      l <- readRef ref
      return $ not (null l)
  isTruthy obj@(Object {}) = isTruthy =<< invoke obj "__bool__" []
  isTruthy _ = return True
  
  toStr :: MonadInterpreter m => Object -> m String
  toStr (None) = return "None"
  toStr (Bool b) = return $ if b then "True" else "False"
  toStr (Bytes _b) = return "b'??'"
  toStr (Float f) = return $ show f
  toStr (Function name _ _ _) = return . T.unpack $ name
  toStr (Imaginary i)
      | realPart i == 0   = return $ show (imagPart i) ++ "j"
      | otherwise         = return $ show i
  toStr (Int i) = return $ show i
  toStr (String s) = return $ T.unpack s
  toStr (Set ref) = do
      items <- readRef ref
      strItems <- mapM toStr $ IntMap.elems items
      return $ "{" ++ intercalate ", " strItems ++ "}"
  toStr (BuiltinFn name)  = return $ "<built-in function " ++ T.unpack name ++ ">"
  toStr (List _) = return "<internal listref>"
  toStr (Dict _) = return "<internal dictref>"
  toStr (Class info) = return $ "<class '" ++ T.unpack (moduleName . classModule $ info) ++ "." ++ T.unpack (className info) ++ "'>"
  toStr (Lambda {}) = return "<function <lambda>>"
  toStr obj@(Object {}) = do
      str <- invoke obj "__str__" []
      case str of
          String s    -> return . T.unpack $ s
          _           -> toStr str
  toStr (Method name (ClassBinding clsName _) _ _ _) = 
      return $ "<method '" ++ T.unpack name ++ "' of '" ++ T.unpack clsName ++ "' objects>"
  toStr (Method name (InstanceBinding clsName obj) _ _ _) = do
      s <- toStr obj
      return $ "<bound method " ++ T.unpack clsName ++ "." ++ T.unpack name ++ " of " ++ s ++ ">"
  toStr (Module info) = return $ "<module '" ++ T.unpack (moduleName info) ++ "'"
  