{-# OPTIONS -fglasgow-exts #-}
-- 
-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
--               2005   Stefan Wehr - http://www.stefanwehr.de
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
-- 

module Phrac.Interpreter where

import Maybe ( isJust, fromJust )
import qualified List
import Data.Generics as Gen

import qualified Phrac.Map as Map
import Phrac.AbstractSyntax
import Phrac.Symtab
import Phrac.Error
import Phrac.Pretty
import Phrac.Builtins
import Phrac.UniqIdents ( builtinDataId, isMain, isError, mkValId )

-- ---------------------------------------------------------------------
-- 
-- This type defines our environment. A map of variables to runtime Values.
--
type Env = Map.Map ValId Value

emptyEnv = Map.empty

lookupEnv :: ValId -> Env -> Value
lookupEnv id env = 
    case Map.lookup id env of
      Nothing -> panic ("undefined variable: " ++ showPpr' id)
      Just v -> v

extendEnv :: ValId -> Value -> Env -> Env
extendEnv = Map.insert

extendEnv' :: [(ValId, Value)] -> Env -> Env
extendEnv' assocs env = 
    foldr (\ (k,v) m -> Map.insert k v m) env assocs

-- 
-- Runtime values are a subset of expressions, these are bound to
-- variables in the heap, and returned as the result of the interpreter.
--
data Value
    = IntVal Integer
    | CharVal Char
    | DataVal DataId [Value]
    | ClosVal Closure
    | DictVal Env [(ValId, Method)]
    | ThunkVal Env Exp
      deriving (Show)

data Closure = Closure Env [Pat] Exp
             deriving (Show)


printStringList :: Value -> String
printStringList (DataVal _ (CharVal c : rest : [])) = c : printStringList rest
printStringList (DataVal _ []) = ""

pprExp exp = 
    if length (show $ ppr exp) < 1000 
       then ppr exp 
       else text "some_expression"

instance Pretty Value where 
    pprPrec _ (IntVal i) = text . show $ i
    pprPrec _ (CharVal c) = text . show $ c
    pprPrec prec d@(DataVal did (CharVal _ : _)) 
        | did == consDataConstructorId = text $ show $ printStringList d
    pprPrec prec (DataVal did vs) =
        parens `usedWhen` (prec > minPrec && not (null vs)) $
        hsep (ppr did : map (pprPrec maxPrec) vs)
    pprPrec prec (ClosVal c) = pprPrec prec c
    pprPrec prec (DictVal env d) = pprPrec prec (Dictionary d)
    pprPrec prec (ThunkVal env e) = 
        text "<THUNK" <+> pprExp e <> text ">"

instance Pretty Closure where
    ppr (Closure env params exp) = 
        text "<CLOSURE" <+> (pprList " " params) <+> text "->" 
        <+> pprExp exp <> text ">"

-- ---------------------------------------------------------------------
--
--

evalProgram :: Program -> ST Value
evalProgram prog = 
    do display ("starting interpreting program")
       v <- eval emptyEnv $ Letrec (prog_bindings prog) (Var mainId)
       forceAllThunks v
    where
    mainId = 
        case List.find (isMain . vbind_name) (prog_bindings prog) of
          Nothing -> phasefail ("no main function defined")
          Just b ->
            if not (null (vbind_pats b))
               then phasefail ("main function cannot take arguments")
               else vbind_name b

-- ---------------------------------------------------------------------
-- Evaluate expressions

forceAllThunks :: Value -> ST Value
forceAllThunks iv@(IntVal _) = return iv
forceAllThunks cv@(CharVal _) = return cv
forceAllThunks (DataVal did vs) = 
    do vs' <- mapM forceAllThunks vs
       return (DataVal did vs')
forceAllThunks dict@(DictVal _ _) = return dict
forceAllThunks (ThunkVal env e) = 
    do v <- eval env e
       forceAllThunks v
forceAllThunks clos@(ClosVal _) = return clos

forceThunk :: Value -> ST Value
forceThunk (ThunkVal env e) = 
    do v <- eval env e
       forceThunk v
forceThunk v = return v

evalStrict :: Env -> Exp -> ST Value
evalStrict env exp = 
    do v <- eval env exp
       forceThunk v

eval :: Env -> Exp -> ST Value
eval env (Var x) = 
    do debug "evalVar"
       if isError x
          then let arg = mkValId "__ error argument __" (-1)
                   in return $ ClosVal $ Closure emptyEnv [PVar arg] (UserError arg)
          else let v = lookupEnv x env
                   in return v

eval _ (Const (Number i)) = 
    do debug "evalConstNumber"
       return $ IntVal i

eval _ (Const (Character c)) = 
    do debug "evalConstCharacter"
       return $ CharVal c

eval env (Prim op [e1, e2]) =
      do debug "evalPrimOp"
         IntVal i <- evalStrict env e1
         IntVal j <- evalStrict env e2
         case op of
           IntAddOp   -> return $ IntVal (i +  j)
           IntSubOp   -> return $ IntVal (i -  j)
           IntMulOp   -> return $ IntVal (i *  j)
           IntRemOp   -> return $ IntVal (i `rem` j)
           IntGtOp    -> return $ boolVal (i >  j)
           IntGeOp    -> return $ boolVal (i >= j)
           IntLtOp    -> return $ boolVal (i <  j)
           IntLeOp    -> return $ boolVal (i <= j)
           IntEqOp    -> return $ boolVal (i == j)
           IntNeOp    -> return $ boolVal (i /= j)
           IntQuotOp  
             | j /= 0    -> return $ IntVal (i `quot` j)
             | otherwise -> phasefail "divide by zero" 
           _          -> panic ("unknown binary operator: " ++ showPpr' op)

eval env (Prim IntNegOp [e]) = 
    do debug "evalPrimNegOp"
       IntVal i <- evalStrict env e
       return $ IntVal (-i)

eval _ op@(Prim _ _) = panic ("unknown primitive operator: " ++ showPpr' op)

eval env (Con did es) = 
    do debug "evalCon"
       es' <- mapM (eval env) es
       return $ DataVal did es'

eval env e@(App e1 e2) = 
    do debug "evalApp"
       v1 <- evalStrict env e1
       case v1 of
         ClosVal (Closure fenv (p:ps) f) ->
             do l <- matchPattern p (ThunkVal env e2)
                case l of
                  Nothing -> phasefail ("pattern match failure")
                  Just binds -> 
                      let fenv' = extendEnv' binds fenv
                          in if null ps -- saturated application
                                then eval fenv' f
                                else return $ ClosVal (Closure fenv' ps f)
         ClosVal (Closure _ [] _) ->
             panic ("closure with empty argument list")
         v -> panic ("value of wrong type on lhs of application: " ++ 
                     showPpr' v)
    where var :: ValId -> [ValId]
          var x = [x]

eval env (Lam [] e) = 
    do debug "evalLam[]"
       eval env e

eval env (Lam pats e) = 
    do debug "evalLam"
       return $ ClosVal (Closure env pats e)

eval env (If e1 e2 e3) = 
    do debug "evalIf"
       v1 <- evalStrict env e1
       case v1 of
         (DataVal did []) | did == trueDataConstructorId -> eval env e2
                          | did == falseDataConstructorId -> eval env e3
                          | otherwise -> 
                              panic ("wrong data constructor in if: " ++ 
                                     showPpr' did)
         v -> panic ("value of wrong type in if: " ++ showPpr' v)
          

{-
  
The recursive letrec is unrolled by the following trick:
  
Define the context L := letrec f1 x11 ... x1M = e1 
                               ... 
                               fN xN1 ... xNM' = eN 
                        in []

Now we can define a reduction rule as follows:

L[e] --> (\f1 ... \fN . e) (\x11 ... \x1M . L[e1]) ... (\xN1 ... \xNM' . L[eN])

Then we can evaluate the reduced expression instead of the original expression.

-}
eval env (Letrec binds e) = 
    let bindIds = map vbind_name binds
        pats = map vbind_pats binds
        es = map vbind_exp binds
        args = map (\ (ps, e') -> Lam ps (Letrec binds e')) (zip pats es)
        lambda = Lam (map PVar bindIds) e
        nextE = foldl App lambda args
        in do debug ("evalLetrec")
              eval env nextE

eval env (Case e alts) = 
    do debug "evalCase"
       v <- eval env e
       (binds, exp) <- findAlt v alts
       eval (extendEnv' binds env) exp
    where findAlt _ [] = phasefail ("pattern match failure")
          findAlt v (a:as) = 
              do l <- matchPattern (alt_pat a) v
                 case l of
                   Just x -> return (x, alt_exp a)
                   Nothing -> findAlt v as

eval env (Overloading dr@(DictionaryReference cid ts)) = 
    do debug ("resolving dictionary reference " ++ showPpr' dr)
       x <- findDictionaryExpression cid ts
       case x of
         Nothing -> panic ("cannot resolve dictionary reference " ++
                           showPpr' dr)
         Just e -> 
             do debug ("dictionary reference " ++ showPpr' dr ++ " resolves to "
                       ++ showPpr' e)
                eval env e

eval env (Overloading (DictionaryLookup id e)) = 
    do debug ("dictionary lookup for " ++ showPpr' id ++ ", expression: " 
              ++ showPpr e)
       dict <- evalStrict env e
       case dict of
         d@(DictVal dictEnv l) ->
             case List.lookup id l of
               Just (Method m e') -> 
                   do -- enter variables for context dictionaries into
                      -- the environment
                      let vs = map (\k -> lookupEnv k dictEnv) (map fst m)
                          ks = map snd m
                      eval (extendEnv' (zip ks vs) env) e'
               Just (SuperMethod id' e') ->
                   eval env (Overloading $ DictionaryLookup id' e')
               Nothing -> panic ("method " ++ showPpr' id ++ 
                                 " not found in dictionary " ++ showPpr d)
         v -> panic ("expected dictionary, got: " ++ showPpr' v)

eval env (Overloading (Dictionary l)) = return (DictVal env l)

eval env (Overloading o) = 
    panic ("unexpected overloading value: " ++ showPpr o)
    
eval env (Error s) = panic s

eval env (UserError x) = 
    do val <- evalStrict env (Var x)
       let s = printStringList val
       panic ("User error: " ++ s)

matchPattern :: Pat -> Value -> ST (Maybe [(ValId, Value)])
matchPattern (PAs i p) v =
    do x <- matchPattern p v
       case x of
         Nothing -> return Nothing
         Just l -> return $ Just ((i, v) : l)
matchPattern PWildcard v = return $ Just []
matchPattern (PVar x) v = return $ Just $ [(x, v)]
matchPattern (PCon id pats) v = 
    do v' <- forceThunk v
       case v' of
         DataVal id' vs | id == id' && length pats == length vs
               -> do l <- mapM (uncurry matchPattern) (zip pats vs)
                     if all isJust l
                        then return $ Just $ concatMap fromJust l
                        else return Nothing
         _ -> return Nothing

--
-- Helpers
--

boolVal :: Bool -> Value
boolVal True = (DataVal trueDataConstructorId [])
boolVal False = (DataVal falseDataConstructorId [])

trueDataConstructorId = builtinDataId (fst trueDataConstructor)
falseDataConstructorId = builtinDataId (fst falseDataConstructor)

consDataConstructorId = builtinDataId (fst consDataConstructor)
nilDataConstructorId = builtinDataId (fst nilDataConstructor)