{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-}

module PIL.Native.Eval (evalNativeLang, resumeNativeLang, EvalResult(..)) where
import PIL.Native.Prims
import PIL.Native.Types
import PIL.Native.Pretty
import PIL.Native.Coerce
import PIL.Native.Objects
import PIL.Native.Parser
import PIL.Native.Bootstrap
import Data.FunctorM
import Data.Dynamic
import Data.Maybe
import Control.Monad.State
import Control.Monad.Reader
import Control.Exception

{-| 

PIL.Native.Eval

This is an evaluator for the core runtime mini-language.

See Also:

  PIL.Native.Parser
  PIL.Native.Prims  
  PIL.Native.Pretty  

-}

type Eval = StateT ObjectSpace (ReaderT Pad IO)
data EvalResult = MkEvalResult
    { result_value  :: !Native
    , result_pad    :: !Pad
    , result_objs   :: !ObjectSpace
    }
    deriving (Typeable)

instance MonadSTM Eval where
    liftSTM = lift . lift . liftSTM

evalNativeLang :: [NativeLangExpression] -> IO EvalResult
evalNativeLang exps = do
    res <- handleResult .  (`runReaderT` empty) . (`runStateT` empty) $ bootstrap
    resumeNativeLang res exps

bootstrap :: Eval Native
bootstrap = bootstrapClass $ evalExps (fromJust $ parseNativeLang __BOOTSTRAP__)

resumeNativeLang :: EvalResult -> [NativeLangExpression] -> IO EvalResult
resumeNativeLang res exps = do
    handleResult . (`runReaderT` result_pad res) .
                   (`runStateT` result_objs res) . evalExps $ exps

handleResult :: IO (Native, ObjectSpace) -> IO EvalResult
handleResult f = do
    (NError err, objs) <- f
    let (val, pad) = fromJust . fromDynamic . fromJust . dynExceptions $ err
    return $ MkEvalResult val pad objs

bootstrapClass :: Eval a -> Eval a
bootstrapClass x = mdo
    clsNull   <- createOpaque clsNull  $ mkClassMethods "" []
    clsClass  <- createOpaque clsClass $ mkClassMethods "Class" [("add_method", addMethod)]
    -- clsBoxes  <- mapM (newBoxedClass clsClass) unboxedTypes
    enterLex ( ("^", clsNull) : ("^Class", clsClass)
    --          : (unboxedTypes `zip` clsBoxes)
                :[]
             ) x
    where
    addMethod = parseSub
        "-> $name, &method { self`set_attr_hash('%!methods', $name, &method) }"
    mkClassMethods :: String -> [(String, Native)] -> NativeMap
    mkClassMethods name meths = mkMap
        [ ("$!name",            toNative name)
        , ("@!MRO",             emptySeq)
        , ("@!subclasses",      emptySeq)
        , ("@!superclasses",    emptySeq)
        , ("%!private_methods", emptyMap)
        , ("%!attributes",      emptyMap)
        , ("%!methods", toNative $ mkMap meths)
        ]
{-
    newBoxedClass cls name = newObject cls $
        mkClassMethods (tail name) [("unbox", parseSub "->{ self`get_attr('') }")]
    unboxedTypes = map ('^':) $ words "Bit Int Num Str Seq Map Sub"
    newContainerClass cls name gen = registerClass $ do
        obj <- genObject cls $ mkClassMethods name []
        return (addRepr obj "create" gen)
-}

infixl ...
(...) :: IsNative a => NativeObj -> String -> Eval a
obj ... str = liftSTM (fmap fromNative $ callRepr (o_repr obj) _get_attr (mkSeq [toNative str]))

enterLex :: IsNative a => [(String, a)] -> Eval b -> Eval b
enterLex = local . append . mkPad

mkPad :: IsNative a => [(String, a)] -> Pad
mkPad = mkMap . map (\(x, y) -> (x, toNative y))

evalExps :: [NativeLangExpression] -> Eval Native
evalExps []       = return nil
evalExps [x]      = evalExp x
evalExps (x:ESaveContinuation:_) = do
    pad <- ask
    val <- evalExp x
    return . toNative $ mkErr (val, pad)
evalExps (x:xs)   = evalExp x >> evalExps xs

evalExp :: NativeLangExpression -> Eval Native
evalExp ESaveContinuation = do
    pad <- ask
    return . toNative $ mkErr (nil, pad)
evalExp (ELit (NSub s)) = do
    pad <- ask -- close over current scope
    return $ NSub s{ s_pad = pad }
evalExp (ELit n) = return n
evalExp (EVar s) = do
    pad <- ask
    case pad `fetch` s of
        Just v  -> return v
        Nothing -> failWith "No such variable" s
evalExp (ECall { c_type = ctyp, c_obj = objExp, c_meth = meth, c_args = argsExp }) = do
    obj  <- evalExp objExp
    args <- fmapM evalExp argsExp
    case ctyp of
        CPrim    -> primCall obj meth args
        CPublic  -> sendCall obj meth args
        CPrivate -> privCall obj meth args

primCall :: Native -> NativeLangMethod -> NativeSeq -> Eval Native
primCall inv meth args
    | meth == mkStr "trace"         = traceObject inv args
    | otherwise = case anyPrims `fetch` meth of
        Just f  -> return $ f inv args
        Nothing -> case inv of
            NError {}   -> errMethodMissing
            NBit x | meth == mkStr "if_else"
                        -> callConditional x args
            NBit x      -> callPrim bitPrims x args
            NInt x      -> callPrim intPrims x args
            NNum x      -> callPrim numPrims x args
            NStr x      -> callPrim strPrims x args
            NSeq x      -> callPrim seqPrims x args
            NMap x      -> callPrim mapPrims x args
            NSub x      -> callSubWith (toString meth) x args
            NObj obj    -> case objPrims `fetch` meth of
                Just f  -> f obj args
                Nothing -> liftSTM $ callRepr (o_repr obj) meth args
                {-
                case Map.lookup meth (o_repr obj) of
                    Just f  -> liftSTM (f args)
                    Nothing -> errMethodMissing
                -}
    where
    errMethodMissing = failWith "No such method" meth
    callPrim :: MapOf (a -> NativeSeq -> Native) -> a -> NativeSeq -> Eval Native
    callPrim prims x args = case prims `fetch` meth of
        Nothing -> errMethodMissing
        Just f  -> return $ f x args

enterObj :: NativeObj -> (NativeObj -> Eval a) -> Eval a
enterObj obj f = enterLex [("&self", obj), ("$?CLASS", cls)] (f cls)
    where
    cls = o_class obj

privCall :: Native -> NativeLangMethod -> NativeSeq -> Eval Native
privCall inv meth args = case inv of
    NObj obj    -> enterObj obj $ \cls -> do
        meths <- cls ... "%!private_methods" :: Eval NativeMap
        case meths `fetch` meth of
            Just x  -> callSub (fromNative x) args
            Nothing -> errMethodMissing
    _           -> errMethodMissing
    where
    errMethodMissing = failWith "No such method" meth

sendCall :: Native -> NativeLangMethod -> NativeSeq -> Eval Native
sendCall inv meth args = case inv of
    NObj obj    -> callObject obj meth args
    NError{}    -> errMethodMissing
    NBit x      -> callAutoboxed x
    NInt x      -> callAutoboxed x
    NNum x      -> callAutoboxed x
    NStr x      -> callAutoboxed x
    NSeq x      -> callAutoboxed x
    NMap x      -> callAutoboxed x
    NSub x      -> callAutoboxed x
    where
    errMethodMissing = failWith "No such method" meth
    callAutoboxed _ = errMethodMissing
    {-
    callAutoboxed x = do
        cls <- fmap fromNative $ evalExp (EVar $ boxType x)
        obj <- autobox x cls
        callObject obj meth args
    -}

callSub :: NativeSub -> NativeSeq -> Eval Native
callSub sub args = do
    when (size args /= size prms) $ do
        fail $ "Invalid number of args " ++ show (elems args)
            ++ " vs params " ++ show (elems prms)
            ++ " in subroutine:\n"
            ++ (pretty $ s_exps sub)
    local (append lex . append (s_pad sub)) $ do
        evalExps (elems $ s_exps sub)
    where
    prms = s_params sub
    lex = fromAssocs ((mkStr "&?SUB", toNative sub):elems prms `zip` elems args)

callSubWith :: String -> NativeSub -> NativeSeq -> Eval Native
callSubWith ""          sub args = callSub sub args
callSubWith "do_if"     sub args = if fromNative (args ! 0) then callSub sub empty else return nil
callSubWith "do_unless" sub args = if fromNative (args ! 0) then return nil else callSub sub empty
callSubWith "do_for"    sub args = fmap toNative $ fmapM (callSub sub . mkSeq . (:[])) (fromNative (args ! 0) :: NativeSeq)
callSubWith _ _ _ = fail "autoboxing for Sub not yet implemented"
{-
callSubWith str x args = do
    cls <- fmap fromNative $ evalExp (EVar $ boxType x)
    obj <- autobox x cls
    callObject obj (mkStr str) args
-}

callConditional :: NativeBit -> NativeSeq -> Eval Native
callConditional x args = callSub (fromNative $ args ! fromEnum (not x)) empty

traceObject :: Native -> NativeSeq -> Eval Native
traceObject obj args = liftIO $ do
    mapM_ doTrace (obj: elems args)
    return obj
    where
    doTrace x = do
        p <- prettyM x
        putStrLn $ "#trace# " ++ unwords (words (unwords (lines p)))

callObject :: NativeObj -> NativeStr -> NativeSeq -> Eval Native
callObject obj meth args = enterLex lex $ do
    mros    <- getMRO
    rv      <- findMRO mros
    case rv of
        Nothing -> failWith "No such method" meth
        Just (this, mros') -> do
            rv' <- genNext mros'
            case rv' of
                Just next -> enterLex [("&?NEXT", toNative next)] $
                    callSub this args
                Nothing -> callSub this args
    where
    lex = [("&self", obj), ("$?CLASS", cls)]
    cls = o_class obj
    genNext mros = do
        rv <- findMRO mros
        case rv of
            Nothing -> return Nothing
            Just (next, mros') -> do
                rv' <- genNext mros'
                let next' = maybe nil toNative rv'
                return $ Just next
                    { s_pad = s_pad next
                                `append` mkPad lex
                                `append` mkPad [("&?NEXT", next')]
                    }
    getMRO = do
        mro <- cls ... "@!MRO" :: Eval NativeSeq
        if isEmpty mro
            then do
                sups <- cls ... "@!superclasses"
                return (cls:map fromNative sups)
            else return (map fromNative $ elems mro)
    findMRO [] = return Nothing
    findMRO (c:cs) = do
        meths <- c ... "%!methods" :: Eval NativeMap
        case meths `fetch` meth of
            Just x  -> return $ Just (fromNative x, cs)
            _       -> findMRO cs

mroMerge :: Eq a => [[a]] -> [a]
mroMerge = reverse . doMerge []
    where
    doMerge res seqs
        | seqs'@(_:_) <- filter (not . null) seqs
        , (cand:_) <- [ s | (s:_) <- seqs', all (not . elem s . tail) seqs']
        = doMerge (cand:res) [ if s == cand then rest else full | full@(s:rest) <- seqs' ]
    doMerge res _ = res

__superclasses, __MRO :: NativeLangMethod
__superclasses  = mkStr "superclasses"
__MRO           = mkStr "MRO"

objPrims :: MapOf (NativeObj -> NativeSeq -> Eval Native)
objPrims = mkMap
    [ ("id", \obj _ -> return (toNative $ o_id obj))
    , ("meta", \obj _ -> return (toNative $ o_class obj))
    , ("repr", \obj _ -> return (toNative $ objectReprName obj))
    , ("create", \cls args -> do
        let repr = fromNative (args ! 0)
            init = (args ! 1)
        fmap toNative (createObject cls repr init))
    -- XXX - move away the two prims below!
    , ("mro_merge", \cls _ -> do
        supers <- fmap fromNative $ callObject cls __superclasses empty
            :: Eval [NativeObj]
        mros   <- fmapM (\c -> fmap fromNative $ callObject c __MRO empty) supers
            :: Eval [[NativeObj]]
        let seqs = filter (not . null) $ ([cls]:mros) ++ [supers]
        return . toNative $ mkSeq (mroMerge seqs)
      )
    ]