{-# LANGUAGE ForeignFunctionInterface,TypeSynonymInstances #-}
module M0ld.Eval (evalM0ld) where 

import Foreign
import Foreign.C.Types
import Foreign.C.String
import Debug.Trace
import M0ld.M0ld
import M0ld.AST
import M0ld.Parser

foreign import ccall "smop.h smop_init"
      smop_init :: IO ()
foreign import ccall "smop.h smop_destr"
      smop_destr :: IO ()
type SMOP__Object = Ptr ()
type Object = ForeignPtr ()

foreign import ccall "smop_haskell_ffi.h get_SMOP__GlobalInterpreter"
      interpreter :: SMOP__Object

foreign import ccall "smop_haskell_ffi.h smop_reference"
      c_smop_reference :: SMOP__Object -> SMOP__Object -> IO SMOP__Object
foreign import ccall "smop_haskell_ffi.h smop_release"
      c_smop_release :: SMOP__Object -> SMOP__Object -> IO SMOP__Object
foreign import ccall "smop_haskell_ffi.h smop_dispatch"
      c_smop_dispatch :: SMOP__Object -> SMOP__Object -> SMOP__Object -> SMOP__Object -> IO SMOP__Object
foreign import ccall "smop_haskell_ffi.h smop_ri"
      c_smop_ri :: SMOP__Object -> SMOP__Object
foreign import ccall "smop_haskell_ffi.h smop_describe_object"
      c_smop_describe_object :: SMOP__Object -> IO ()

describe_object obj = do 
    ptr <- smopify obj
    c_smop_describe_object ptr

foreign import ccall "smop_native.h SMOP__NATIVE__idconst_createn"
      c_SMOP__NATIVE__idconst_createn :: Ptr CChar -> Int -> SMOP__Object
idconst_ptr str = unsafePerformIO $ withCStringLen str  (\cstr -> return $ c_SMOP__NATIVE__idconst_createn (fst cstr) (snd cstr))
idconst str = unsafePerformIO $ auto_release $ idconst_ptr str 

foreign import ccall "smop_native.h SMOP__NATIVE__int_create"
    c_SMOP__NATIVE__int_create :: Int -> IO SMOP__Object
int_create int = c_SMOP__NATIVE__int_create int >>= auto_release

foreign import ccall "smop_native.h SMOP__NATIVE__capture_create"
    c_SMOP__NATIVE__capture_create :: SMOP__Object -> SMOP__Object -> Ptr SMOP__Object -> Ptr SMOP__Object -> SMOP__Object

capture_create :: SMOP__Object -> [SMOP__Object] -> [SMOP__Object] -> SMOP__Object
capture_create inv pos named = unsafePerformIO $ (withArray0 nullPtr pos (\cpos -> withArray0 nullPtr named (\cnamed -> return $ c_SMOP__NATIVE__capture_create interpreter inv cpos cnamed)))

foreign import ccall "smop_mold.h SMOP__Mold_create"
    c_SMOP__Mold_create :: Int -> Ptr SMOP__Object -> Int -> Ptr Int -> IO SMOP__Object


foreign import ccall "smop_haskell_ffi.h &smop_release_with_global"
    p_release :: FunPtr (Ptr a -> IO ())

foreign import ccall "smop_haskell_ffi.h smop_get_cvar"
    smop_get_cvar :: CString -> IO SMOP__Object

get_cvar str = do
    obj <- withCString str smop_get_cvar
    auto_release obj

auto_release :: SMOP__Object -> IO Object
auto_release ptr = do 
    c_smop_reference interpreter ptr
    newForeignPtr p_release ptr

foreign import ccall "smop_haskell_ffi.h get_SMOP__S1P__RootNamespace"
      get_SMOP__S1P__RootNamespace :: IO SMOP__Object

rootnamespace = do
    root <- get_SMOP__S1P__RootNamespace
    auto_release root

class Smopify a where
    smopify :: a -> IO SMOP__Object


instance Smopify Object where
    smopify a = withForeignPtr a (\ptr -> do
        c_smop_reference interpreter ptr 
        return ptr)
instance Smopify SMOP__Object where
    smopify a = return a
instance Smopify String where
    smopify a = return (idconst_ptr a)

mold :: (Smopify a) => Int -> [a] -> [Int] -> IO Object
mold regs constants opcodes = do
    constants_ <- mapM smopify constants
    new_mold <- withArray0 nullPtr constants_ (\c_constants -> withArray opcodes (\c_opcodes -> c_SMOP__Mold_create regs c_constants (length opcodes) c_opcodes))
    auto_release new_mold

call inv ident pos named = do
    inv_ <- smopify inv
    ident_ <- smopify ident
    pos_ <- mapM smopify pos
    named_ <- mapM smopify named
    obj <- c_smop_dispatch interpreter (c_smop_ri inv_) ident_ (capture_create inv_ pos_ named_)
    auto_release obj

-- Hack to satisfy the type system
none :: [SMOP__Object]
none = []

metachars :: [Char] -> [Char]
metachars str = case str of
    [] -> ""
    '\\':'n':rest -> '\n' : (metachars rest)
    '\\':other:rest -> other : (metachars rest)
    letter:rest -> letter : (metachars rest)

createConstant :: Value -> IO Object
createConstant constant = case constant of
    Var var -> get_cvar var
    IntegerConstant int -> int_create $ fromInteger int
    StringConstant str -> return $ idconst $ metachars $ str
    SubMold stmts -> createM0ld stmts

compileM0ld = createM0ld . parseM0ld

createM0ld ast = do
    let labelsMap = mapLabels ast
        regMap    = mapRegisters ast
        freeRegs  = countRegister ast
        bytecode  = emit ast regMap labelsMap
    constants <- mapM createConstant [c | Decl reg c <- filter (not . isReg) ast]
    mold freeRegs constants bytecode
evalM0ld code = do
    smop_init
    root <- rootnamespace

    -- describe_object root

    -- out_scalar <- call root "postcircumfix:{ }" ["$*OUT"] none
    out_scalar <- call root "lookup_key" ["$*OUT"] none

    -- describe_object out_scalar

    --call out_scalar "DEBUG" none none

    out <- call out_scalar "FETCH" none none

    -- describe_object out

    mold_frame_scalar <- call root "lookup_key" ["::MoldFrame"] none
    mold_frame <- call mold_frame_scalar "FETCH" none none

    test_mold <- compileM0ld code
    test_frame <- call mold_frame "new" [test_mold] none

    c_smop_reference interpreter interpreter
    call interpreter "goto" [test_frame] none

    c_smop_reference interpreter interpreter
    call interpreter "loop" none none
--    smop_destr
    return ()
