{-# OPTIONS -Wall -fno-warn-name-shadowing -XPatternGuards -fglasgow-exts #-}
{- 
Interprets the subset of well-typed Core programs for which
	(a) All constructor and primop applications are saturated
	(b) All non-trivial expressions of unlifted kind ('#') are
             scrutinized in a Case expression.

This is by no means a "minimal" interpreter, in the sense that considerably
simpler machinary could be used to run programs and get the right answers.
However, it attempts to mirror the intended use of various Core constructs,
particularly with respect to heap usage.  So considerations such as unboxed
tuples, sharing, trimming, black-holing, etc. are all covered.
The only major omission is garbage collection.

Just a sampling of primitive types and operators are included.
-}

module Language.Core.Interp ( evalProgram ) where

import Control.Monad.Error
import Control.Monad.State
import Data.Char
import Data.List

import qualified Data.Map as M
import GHC.Exts hiding (Ptr)
import System.IO

import Language.Core.Core
import Language.Core.Env
import Language.Core.Printer()

data HeapValue = 
    Hconstr Dcon [Value]       -- constructed value (note: no qualifier needed!)
  | Hclos Venv Var Exp         -- function closure
  | Hthunk Venv Exp            -- unevaluated thunk
  deriving (Show)

type Ptr = Int

data Value = 
    Vheap Ptr 		       -- heap pointer (boxed)
  | Vimm PrimValue     	       -- immediate primitive value (unboxed)
  | Vutuple [Value]            -- unboxed tuples
  deriving (Show)

instance Error Value where
  -- TODO: ??
  strMsg s = error s

type Venv = M.Map Var Value       -- values of vars

data PrimValue =                -- values of the (unboxed) primitive types
    PCharzh Integer		-- actually 31-bit unsigned
  | PIntzh Integer		-- actually WORD_SIZE_IN_BITS-bit signed
  | PWordzh Integer		-- actually WORD_SIZE_IN_BITS-bit unsigned
  | PAddrzh Integer		-- actually native pointer size
  | PFloatzh Rational		-- actually 32-bit 
  | PDoublezh Rational		-- actually 64-bit
--  etc., etc.
  | PString String
  deriving (Eq,Show)

type Menv = M.Map AnMname Venv	-- modules

initialGlobalEnv :: Menv
initialGlobalEnv =
    efromlist
	[(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]

{- Heap management. -}
{- Nothing is said about garbage collection. -}

data Heap = Heap Ptr (M.Map Ptr HeapValue) 
    -- last cell allocated; environment of allocated cells
  deriving Show

hallocate :: Heap -> HeapValue -> (Heap,Ptr)
hallocate (Heap last contents) v = 
   let next = last+1
   in (Heap next (eextend contents (next,v)),next)

hupdate :: Heap -> Ptr -> HeapValue -> Heap
hupdate (Heap last contents) p v =
   Heap last (eextend contents (p,v))

hlookup:: Heap -> Ptr -> HeapValue
hlookup (Heap _ contents) p =
   case elookup contents p of
     Just v -> v
     Nothing -> error "Missing heap entry (black hole?)"

hremove :: Heap -> Ptr -> Heap
hremove (Heap last contents) p = 
   Heap last (eremove contents p)

hempty :: Heap
hempty = Heap 0 eempty

{- The evaluation monad manages the heap and the possiblity 
   of exceptions. -}

type Exn = Value

type Eval a = ErrorT Exn (StateT Heap IO) a

hallocateE :: HeapValue -> Eval Ptr
hallocateE v = do
  h <- get
  let (h', p) = hallocate h v
  put h'
  return p

hupdateE :: Ptr -> HeapValue -> Eval ()
hupdateE p v = modify (\ h -> hupdate h p v)

hlookupE :: Ptr -> Eval HeapValue
hlookupE p =  get >>= (\h -> return (hlookup h p))

hremoveE :: Ptr -> Eval ()
hremoveE p = modify (\h -> hremove h p)

raiseE :: Exn -> Eval a
raiseE = throwError

catchE :: Show a => Eval a -> (Exn -> Eval a) -> Eval a
catchE = catchError

runE :: Eval a -> IO a
runE m = do
  resultOrError <- evalStateT (runErrorT m) hempty
  case resultOrError of
    Right v -> return v
    Left exn -> error
      ("evaluation failed with uncaught exception: " ++ show exn)

{- Main entry point -}
-- TODO: This is in the IO monad because primitive I/O ops
-- actually perform the IO. It might be better to model it
-- instead (by having the interpreter return a ([Char] -> (Value, [Char])))
evalProgram :: [Module] -> IO Value
evalProgram modules = runE $ do
     -- We do two passes: one to slurp in all the definitions *except*
     -- for :Main.main, and then one to look for the Main module
     -- and extract out just the :Main.main defn.
     -- It's kind of annoying.
     globalEnv' <- foldM evalModule initialGlobalEnv modules
     globalEnv  <- evalModule globalEnv' (rootModule modules)
     Vutuple [_,v] <- evalExp globalEnv eempty (App (Var mainVar)
                       stateToken)
     return v

rootModule :: [Module] -> Module
-- This looks for the Main module, and constructs
-- a fake module containing only the defn of
-- :Main.main.

-- FIXME: this code actually only expects a single module.
-- It wouldn't be hard to fix it to understand multiple modules.
rootModule ms = case ms of
                   [] -> error "eval: you didn't give me any modules!"
                   (m:_) -> m
{-
  case find (\ (Module mn _ _) -> mn == mainMname) ms of
    Just (Module _ _ [Rec bs]) ->
        Module wrapperMainMname []
          [Rec (filter isWrapperMainVdef bs)]
    _ -> error "eval: missing main module"
  where isWrapperMainVdef (Vdef (v,_,_)) | v == wrapperMainVar = True
        isWrapperMainVdef _ = False
-}

{- Environments:

Evaluating a module just fills an environment with suspensions for all
the external top-level values; it doesn't actually do any evaluation
or look anything up.

By the time we actually evaluate an expression, all external values from
all modules will be in globalEnv.  So evaluation just maintains an environment
of non-external values (top-level or local).  In particular, only non-external
values end up in closures (all other values are accessible from globalEnv.)

Throughout:

- globalEnv contains external values (all top-level) from all modules seen so far.

In evalModule:

- e_venv    contains external values (all top-level) seen so far in current module
- l_venv    contains non-external values (top-level or local)  
                 seen so far in current module.
In evalExp:

- env	    contains non-external values (top-level or local) seen so far
		in current expression.
-}


evalModule :: Menv -> Module -> Eval Menv
evalModule globalEnv (Module mn _ vdefgs) =
  do (e_venv,_) <- foldM evalVdef (eempty,eempty) vdefgs
     return (eextend globalEnv (mn,e_venv))
  where
    evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
    evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),_,e))) =
     do p <- hallocateE (suspendExp l_env e)
	let heaps =
               case m of
                 Nothing -> (e_env,eextend l_env (x,Vheap p))
	         _       -> (eextend e_env (x,Vheap p),l_env)
	return heaps
    evalVdef (e_env,l_env) (Rec vdefs) =
      do l_vs0 <- mapM preallocate l_xs
	 let l_env' = foldl eextend l_env (zip l_xs (map Vheap l_vs0))
	 let l_hs = map (suspendExp l_env') l_es
	 mapM_ reallocate (zip l_vs0 l_hs)
	 let e_hs = map (suspendExp l_env') e_es
	 e_vs <- (liftM (map Vheap)) $ mapM allocate e_hs
         let e_env' = foldl eextend e_env (zip e_xs e_vs)
	 return (e_env',l_env')            
      where 
	 (l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs]
	 (e_xs,e_es) = unzip [(x,e) | Vdef ((Just _,x),_,e) <-
                         -- Do not dump the defn for :Main.main into
                         -- the environment for Main!
                                       filter inHomeModule vdefs]
         inHomeModule (Vdef ((Just m,_),_,_)) | m == mn = True
         inHomeModule _ = False
	 preallocate _ =
	   do p <- hallocateE undefined
	      return p
	 reallocate (p0,h) =
	   hupdateE p0 h
	 allocate h =
	   do p <- hallocateE h
	      return p

    suspendExp:: Venv -> Exp -> HeapValue
    suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
       where env' = thin env (delete x (freevarsExp e))
    suspendExp env e = Hthunk env' e
       where env' = thin env (freevarsExp e)

evalExp :: Menv -> Venv -> Exp -> Eval Value
evalExp globalEnv env = eval
  where eval (Var qv) = 
          let v = qlookup globalEnv env qv
          in case v of 
               Vheap p -> do
	         z <- hlookupE p                    -- can fail due to black-holing
	         case z of
	           Hthunk env' e -> do
		     hremoveE p                     -- black-hole
                     w <- evalExp globalEnv env' e  -- result is guaranteed to be boxed!
                     case w of
                       Vheap p' -> do
   	                 h <- hlookupE p'
		         hupdateE p h
	                 return w
                       _ -> error ("eval: w was not boxed: " ++ show w)
	           _ -> return v -- return pointer to Hclos or Hconstr
               _ -> return v     -- return Vimm or Vutuple
        eval (Lit l) = return (Vimm (evalLit l))
        eval (Dcon (_,c)) = do
           p <- hallocateE (Hconstr c [])
           return (Vheap p)
        eval (App e1 e2) =
          evalApp env e1 [e2]
            where
              evalApp :: Venv -> Exp -> [Exp] -> Eval Value
              evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
              evalApp env (Dcon (qdc@(_,c))) es = 
                  do vs <- suspendExps globalEnv env es
	             if isUtupleDc qdc
                       then
	                 return (Vutuple vs)
	               else
	                 {- allocate a thunk -}
     	                 do p <- hallocateE (Hconstr c vs)
  	                    return (Vheap p)
              evalApp env (Var(v@(_,p))) es | isPrimVar v =
                 do vs <- evalExps globalEnv env es
                    case (p,vs) of
   	              ("raisezh",[exn]) -> raiseE exn
	              ("catchzh",[body,handler,rws]) ->
	                        catchE (apply body [rws])
	                        (\exn -> apply handler [exn,rws])
  	              _ -> evalPrimop p vs
              evalApp env (External s _) es =
                  do vs <- evalExps globalEnv env es
	             evalExternal s vs
              evalApp env (Appt e _) es     = evalApp env e es
              evalApp env (Lam (Tb _) e) es = evalApp env e es
              evalApp env (Cast e _) es     = evalApp env e es
              evalApp env (Note _ e) es     = evalApp env e es
              evalApp env e es = 
          {- e must now evaluate to a closure -}
                  do vs <- suspendExps globalEnv env es
	             vop <- evalExp globalEnv env e
                     apply vop vs

              apply :: Value -> [Value] -> Eval Value
              apply vop [] = return vop
              apply (Vheap p) (v:vs) =
                  do Hclos env' x b <- hlookupE p
                     v' <- evalExp globalEnv (eextend env' (x,v)) b
                     apply v' vs
              apply _ _ = error ("apply: operator is not a closure")

        eval (Appt e _) = evalExp globalEnv env e
        eval (Lam (Vb(x,_)) e) = do
           p <- hallocateE (Hclos env' x e)
           return (Vheap p)
               where env' = thin env (delete x (freevarsExp e))
        eval (Lam _ e) = evalExp globalEnv env e
        eval (Let vdef e) =
          do env' <- evalVdef globalEnv env vdef
             evalExp globalEnv env' e
            where
              evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
              evalVdef globalEnv env (Nonrec(Vdef((_,x),_,e))) =
                  do v <- suspendExp globalEnv env e
	             return (eextend env (x,v))
              evalVdef globalEnv env (Rec vdefs) =
                  do vs0 <- mapM preallocate xs
	             let env' = foldl eextend env (zip xs (map Vheap vs0))
	             vs <- suspendExps globalEnv env' es
	             mapM_ reallocate (zip vs0 vs)
	             return env'
                  where 
	            (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
	            preallocate _ = 
                        do p <- hallocateE (Hconstr "UGH" [])
	                   return p
	            reallocate (p0,Vheap p) =
	                do h <- hlookupE p
	                   hupdateE p0 h
                    reallocate (_,_) = error "reallocate: expected a heap value"
        eval (Case e (x,_) _ alts) =
            do z <- evalExp globalEnv env e
               let env' = eextend env (x,z)
               case z of
                 Vheap p -> do
	           h <- hlookupE p   -- can fail due to black-holing
	           case h of
	             Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
  	             _ ->               evalDefaultAlt env' alts
                 Vutuple vs ->
	             evalUtupleAlt env' vs (reverse alts)
                 Vimm pv ->
	             evalLitAlt env' pv (reverse alts)
            where
              evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
              evalDcAlt env dcon vs = f
                where
	          f ((Acon (_,dcon') _ xs e):as) =
	             if dcon == dcon' then
	               evalExp globalEnv
                         (foldl eextend env (zip (map fst xs) vs)) e
	             else f as
	          f [Adefault e] =
	            evalExp globalEnv env e
	          f _ = error $ "impossible Case-evalDcAlt"

              evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
              evalUtupleAlt env vs [Acon _ _ xs e] =
                  evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
              evalUtupleAlt _ _ _ = error ("impossible Case: evalUtupleAlt")

              evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
              evalLitAlt env pv alts =
                  f alts
                      where 
	                f ((Alit lit e):as) =
	                    let pv' = evalLit lit
	                    in if pv == pv' then
	                           evalExp globalEnv env e
                               else f as
                        f [Adefault e] =
	                    evalExp globalEnv env e
	                f _ = error "impossible Case-evalLitAlt"
    
              evalDefaultAlt :: Venv -> [Alt] -> Eval Value
              evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
              evalDefaultAlt _ _ = error "evalDefaultAlt: impossible case"

        eval (Cast e _) = evalExp globalEnv env e
        eval (Note _ e) = evalExp globalEnv env e
        eval (External s _) = evalExternal s []

evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
evalExps globalEnv env = mapM (evalExp globalEnv env)

suspendExp:: Menv -> Venv -> Exp -> Eval Value
suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
suspendExp _ _ (Lit l) = return (Vimm (evalLit l))
suspendExp _ env (Lam (Vb(x,_)) e) =
   do p <- hallocateE (Hclos env' x e)
      return (Vheap p)
   where env' = thin env (delete x (freevarsExp e))
suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e
suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
suspendExp _ _ (External s _) = evalExternal s []
suspendExp _ env e =
   do p <- hallocateE (Hthunk env' e)
      return (Vheap p)
   where env' = thin env (freevarsExp e)

suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
suspendExps globalEnv env = mapM (suspendExp globalEnv env)

mlookup :: Menv -> Venv -> Mname -> Venv
mlookup _          env       Nothing  = env
mlookup globalEnv  _         (Just m) = 
    case elookup globalEnv m of
      Just env' -> env'
      Nothing -> error ("Interp: undefined module name: " ++ show m)

qlookup :: Menv -> Venv -> (Mname,Var) -> Value
qlookup globalEnv env (m,k) =
  case elookup (mlookup globalEnv env m) k of
    Just v -> v
    Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)

evalPrimop :: Var -> [Value] -> Eval Value
evalPrimop "zpzh"        = primIntBinop    (+)
evalPrimop "zpzhzh"      = primDoubleBinop (+)
evalPrimop "zmzh"        = primIntBinop    (-)
evalPrimop "zmzhzh"      = primDoubleBinop (-)
evalPrimop "ztzh"        = primIntBinop    (*)
evalPrimop "ztzhzh"      = primDoubleBinop (*)
evalPrimop "zgzh"        = primIntCmpOp    (>)
evalPrimop "zlzh"        = primIntCmpOp    (<)
evalPrimop "zlzhzh"      = primDoubleCmpOp (<)
evalPrimop "zezezh"      = primIntCmpOp    (==)
evalPrimop "zlzezh"      = primIntCmpOp    (<=)
evalPrimop "zlzezhzh"    = primDoubleCmpOp (<=)
evalPrimop "zgzezh"      = primIntCmpOp    (>=)
evalPrimop "zszezh"      = primIntCmpOp    (/=)
evalPrimop "zszhzh"      = primDoubleCmpOp (/=)
evalPrimop "negateIntzh" = primIntUnop     (\ i -> -i)
evalPrimop "quotIntzh"   = primIntBinop    quot
evalPrimop "remIntzh"    = primIntBinop    rem
evalPrimop "subIntCzh"   = primSubIntC
evalPrimop "addIntCzh"   = primAddIntC
evalPrimop "mulIntMayOflozh" = primIntBinop
  (\ i j ->
     case (fromIntegral i, fromIntegral j) of
       (I# x, I# y) -> 
         case x `mulIntMayOflo#` y of
           k -> fromIntegral (I# k))
evalPrimop "narrow32Intzh" = primIntUnop
  (\ i ->
     case fromIntegral i of
       (I# j) -> case narrow32Int# j of
                   k -> fromIntegral (I# k))
evalPrimop "int2Doublezh" = primInt2Double 
-- single-threaded, so, it's a no-op
--evalPrimop "noDuplicatezh" [state] = return state
evalPrimop "indexCharOffAddrzh" = primIndexChar
evalPrimop "eqCharzh"           = primCharCmpOp (==)
evalPrimop "leCharzh"           = primCharCmpOp (<) 
evalPrimop "ordzh"              = primOrd 
evalPrimop "chrzh"              = primChr
-- etc.
evalPrimop p = error ("undefined primop: " ++ p)

primIntUnop :: (Integer -> Integer) -> [Value] -> Eval Value
primIntUnop op [Vimm (PIntzh i)] = return (Vimm (PIntzh (op i)))
primIntUnop _ _ = error "primIntUnop: wrong number of arguments"

primIntBinop :: (Integer -> Integer -> Integer) -> [Value] -> Eval Value
primIntBinop op [Vimm (PIntzh i), Vimm (PIntzh j)] = 
  return (Vimm (PIntzh (i `op` j)))
primIntBinop _ _ = error "primIntBinop: wrong number of arguments"

primDoubleBinop :: (Rational -> Rational -> Rational) -> [Value] -> Eval Value
primDoubleBinop op [Vimm (PDoublezh i), Vimm (PDoublezh j)] = 
  return (Vimm (PDoublezh (i `op` j)))
primDoubleBinop _ _ = error "primDoubleBinop: wrong number of arguments"

primIntCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
primIntCmpOp op [Vimm (PIntzh i), Vimm (PIntzh j)] = mkBool (i `op` j)
primIntCmpOp _ _ = error "primIntCmpOp: wrong number of arguments"

primDoubleCmpOp :: (Rational -> Rational -> Bool) -> [Value] -> Eval Value
primDoubleCmpOp op [Vimm (PDoublezh i), Vimm (PDoublezh j)] = mkBool (i `op` j)
primDoubleCmpOp _ _ = error "primDoubleCmpOp: wrong number of arguments"

primCharCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
primCharCmpOp op [Vimm (PCharzh c), Vimm (PCharzh d)] = mkBool (c `op` d)
primCharCmpOp _ _ = error "primCharCmpOp: wrong number of arguments"

primSubIntC :: [Value] -> Eval Value
primSubIntC vs = carryOp subIntC# vs

primAddIntC :: [Value] -> Eval Value
primAddIntC vs = carryOp addIntC# vs

carryOp :: (Int# -> Int# -> (# Int#, Int# #)) -> [Value] -> Eval Value
carryOp op [Vimm (PIntzh i1), Vimm (PIntzh i2)] =
  case (fromIntegral i1, fromIntegral i2) of
    (I# int1, I# int2) -> 
       case (int1 `op` int2) of
        (# res1, res2 #) -> 
           return $ Vutuple [Vimm (PIntzh (fromIntegral (I# res1))),
                             Vimm (PIntzh (fromIntegral (I# res2)))]
carryOp _ _ = error "carryOp: wrong number of arguments"

primInt2Double :: [Value] -> Eval Value
primInt2Double [Vimm (PIntzh i)] =
  return (Vimm (PDoublezh (fromIntegral i)))
primInt2Double _ = error "primInt2Double: wrong number of arguments"

primOrd :: [Value] -> Eval Value
primOrd [Vimm (PCharzh c)] = return $ Vimm (PIntzh c)
primOrd _ = error "primOrd: wrong number of arguments"

primChr :: [Value] -> Eval Value
primChr [Vimm (PIntzh c)] = return $ Vimm (PCharzh c)
primChr _ = error "primChr: wrong number of arguments"

primIndexChar :: [Value] -> Eval Value
primIndexChar [(Vimm (PString s)), (Vimm (PIntzh i))] = 
  -- String is supposed to be null-terminated, so if i == length(s),
  -- we return null. (If i > length(s), emit nasal demons.)
  return $ let len = fromIntegral $ length s in
             if i < len 
               then Vimm (PCharzh (fromIntegral (ord (s !! fromIntegral i))))
               else if i == len
                      then Vimm (PCharzh 0)
                      else error "indexCharOffAddr#: index too large"
primIndexChar _ = error "primIndexChar: wrong number of arguments"

evalExternal :: String -> [Value] -> Eval Value
-- etc.
-- This is just an example of how we would implement a primop
-- in the External Core interpreter that GHC doesn't treat as
-- a primop.
evalExternal "extcore_hPutChar" [Vimm (PCharzh i), _] =
  liftIO (hPutChar stdout (chr (fromIntegral i))) >>
-- make an unboxed 1-tuple result and return it
-- (UGH!!!)
  returnOneTupleState
evalExternal s vs = error $ "evalExternal undefined for now: " ++ show s ++ " and " ++ show vs -- etc.,etc.

returnOneTupleState :: Eval Value
returnOneTupleState = do    
  p <- hallocateE (Hconstr (snd (dcUtuple 1)) [Vimm (PIntzh 0)])
  return $ Vheap p

evalLit :: Lit -> PrimValue
evalLit (Literal l t) = 
    case l of
      Lint i | (Tcon(_,"Intzh")) <- t -> PIntzh i
      Lint i | (Tcon(_,"Wordzh")) <- t -> PWordzh i
      Lint i | (Tcon(_,"Addrzh")) <- t -> PAddrzh i
      Lint i | (Tcon(_,"Charzh"))<- t -> PCharzh i
      Lrational r | (Tcon(_,"Floatzh"))  <- t -> PFloatzh r
      Lrational r | (Tcon(_,"Doublezh")) <- t -> PDoublezh r
      Lchar c | (Tcon(_,"Charzh")) <- t       -> PCharzh (toEnum (ord c))
      Lstring s | (Tcon(_,"Addrzh")) <- t     -> PString s
          -- should really be address of non-heap copy of C-format string s
          -- tjc: I am ignoring this comment
      _ -> error ("evalLit: strange combination of literal "
             ++ show l ++ " and type " ++ show t)

{- Utilities -}

mkBool :: Bool -> Eval Value
mkBool True = 
  do p <- hallocateE (Hconstr "True" [])
     return (Vheap p)
mkBool False = 
  do p <- hallocateE (Hconstr "False" [])
     return (Vheap p)

thin :: Ord a => M.Map a b -> [a] -> M.Map a b    
thin env vars = efilter env (`elem` vars)

{- Return the free non-external variables in an expression. -}

freevarsExp :: Exp -> [Var]
freevarsExp (Var (Nothing,v)) = [v]
freevarsExp (Var _) = []
freevarsExp (Dcon _) = []
freevarsExp (Lit _) = []
freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
freevarsExp (Appt e _) = freevarsExp e
freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
freevarsExp (Lam _ e) = freevarsExp e
freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
  where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
            where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]	
        freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as
  where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
        freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs) 
        freevarsAlt (Alit _ e) = freevarsExp e
        freevarsAlt (Adefault e) = freevarsExp e
freevarsExp (Cast e _) = freevarsExp e
freevarsExp (Note _ e) =  freevarsExp e
freevarsExp (External _ _) = []

stateToken :: Exp
stateToken = Var (qual primMname "realWorldzh")