module Cont where 

import ContType
import ContParser

{----------------------------------------------------------------------

 インタプリタ

 ----------------------------------------------------------------------}

type Env = [(String, Value)]  

lookupM :: String -> Env -> M Value
lookupM x ((n,v):rest) = if n==x then unitM v else lookupM x rest
lookupM x []           = failM ("Variable: "++x++" is not found")

interpLabeledExpr :: LabeledExpr -> Env -> (Env, Value -> Result) -> (Env, Value -> Result)
interpLabeledExpr (Just id, e) env (xs, c2) =
     let c1 = \ _ -> interp e env c2 in ((id, Cont c1):xs, c1)
interpLabeledExpr (Nothing, e) env (xs, c2) =
     let c1 = \ _ -> interp e env c2 in (xs, c1)

interpLabeledExprSeq :: [LabeledExpr] -> Env -> (Value -> Result) -> (Env, Value -> Result)
interpLabeledExprSeq les env c = foldr (\ le (e, k) -> interpLabeledExpr le env (e, k)) ([], c) les


interp :: Expr -> Env -> M Value
interp (Const c)  e = unitM c
interp (Var x)    e = lookupM x e
interp (Let (x, m) n) e = interp m e `bindM` \ v  ->  
                          interp n ((x,v):e)
{-
-- Continuationのmonadでmfixは定義できない
-- cf. Recursive Monadic Bindings 
--     by Levent Erk\"ok and John Launchbury

interp (Letrec (x, m) n) e = mfix (\ v -> 
                                   interp m ((x,v):e)) `bindM` \ v  ->
                             interp n ((x,v):e)

-- 代わりに関数の再帰のみ許すmfixUを使用する
-}

interp (Letrec (x, m) n) e = mfixU (\ v -> 
                                    interp m ((x, Fun v):e) `bindM` \  v1 ->
                                    case v1 of 
                                      Fun f -> unitM f 
                                      _     -> failM ("function expected:" ++ showValue v1 ++ ":."))
                                 `bindM` \ v  ->
                             interp n ((x, Fun v):e)

interp (App f x) e  = interp f e `bindM` \ g -> 
                      case g of 
                    	Fun h -> interp x e `bindM` \ y ->
                    		 h y
                    	v     -> failM ("App: Function expected:"++ showValue v ++":.")
interp (Lambda x m) e  = unitM (Fun (\ v -> interp m ((x,v):e)))
interp (If e1 e2 e3) e = interp e1 e `bindM` \ v ->
                         case v of 
                           Bool b -> if b then interp e2 e
                        		  else interp e3 e
                           _      -> failM "Boolean expected"
interp (SetX e1) e = interp e1 e `bindM` \ v ->
                     setX v
interp (SetY e1) e = interp e1 e `bindM` \ v ->
                     setY v
interp (SetZ e1) e = interp e1 e `bindM` \ v ->
                     setZ v

interp GetX e = getX
interp GetY e = getY
interp GetZ e = getZ

interp (Begin les) e = \ c -> let (e', c1) = interpLabeledExprSeq les (e'++e) c in c1 Unit
{-
interp (Begin es) e = case es of
                        [(_, f)]   -> interp f e
                        (_, f):fs  -> interp f e `bindM` \ _ ->
                                      interp (Begin fs) e
-}

interp (While e1 e2) e =  
  \ c1 -> 
  let env1 = ("break", Cont c1) : e in 
  interp e1 e (\ v ->
  case v of
     Bool b -> if b then 
                    let c2 = \ _ -> interp (While e1 e2) e c1 in
                    let env2 = ("continue", Cont c2) : env1 in
                    interp e2 env2 c2
               else c1 (Bool True)
     _      -> failM "Boolean expected" c1)
interp Break e = \ c0 -> lookupM "break" e (\ (Cont c) -> 
                         c (Bool False))
interp Continue e = \ c0 -> lookupM "continue" e (\ (Cont c) -> 
                            c (Bool False))
interp Abort e = abortM (unitST ())
{-
interp (Callcc e) = \ env c0 -> 
                    interp e env (\ x ->
                    case x of Fun f -> f (Fun (\ v env1 c1 -> c0 v)) env c0
                              _     -> failM ("Callcc: Function expected")
                                              env c0)
-}
interp (Callcc e1) e = interp e1 e `bindM` \ x ->
                       case x of Fun f -> callccM (\ k -> f (Fun k))
                                 _     -> failM ("Callcc: Function expected")
interp (Goto label) e = \ c0 -> lookupM label e (\ (Cont c) -> 
                                c (Bool False))
               
binop op =  Fun (\ v ->
              case v of
                Num c -> unitM (Fun (\ w ->
                           case w of
                             Num d -> unitM (Num (op c d))
                             _     -> failM "Number expected"))
                _     -> failM "Number expected")

binop2 op =  Fun (\ v ->
	       case v of
		 Num c -> unitM (Fun (\ w ->
			    case w of
			      Num d -> unitM (Bool (op c d))
			      _     -> failM "Number expected"))
		 _     -> failM "Number expected")

divop = Fun (\ v ->
              case v of
                Num c -> unitM (Fun (\ w ->
                           case w of
                             Num 0 -> failM "Division by 0"
                             Num d -> unitM (Num (c/d))
                             _     -> failM "Number expected"))
                _     -> failM "Number expected")

myPair   = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Pair v1 v2))))
myFst    = Fun (\ v -> case v of
                         Pair v1 v2 -> unitM v1
                         _          -> failM "Pair expected")
mySnd    = Fun (\ v -> case v of
                         Pair v1 v2 -> unitM v2
                         _          -> failM "Pair expected")
myTriple   = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Fun (\ v3 ->
             unitM (Pair v1 (Pair v2 v3)))))))
myFst3    = Fun (\ v -> case v of
                         Pair v1 v2 -> unitM v1
                         _          -> failM "Triple expected")
mySnd3    = Fun (\ v -> case v of
                        Pair v1 (Pair v2 _) -> unitM v2
                        _                   -> failM "Triple expected")
myThd3    = Fun (\ v -> case v of
                        Pair v1 (Pair v2 v3) -> unitM v3
                        _                    -> failM "Triple expected")
myToString  = Fun (\ v -> unitM (Str (showValue v)))
myStrAppend = Fun (\ v1 -> unitM (Fun (\ v2 ->
              unitM (Str (showValue v1 ++ showValue v2)))))
myIsPair = Fun (\ v -> case v of
                       Pair _ _ -> unitM (Bool True)
                       _        -> unitM (Bool False))
myIsUnit = Fun (\ v -> case v of
                       Unit -> unitM (Bool True)
                       _        -> unitM (Bool False))


initEnv = [("+", binop (+)), ("-", binop (-)),
           ("*", binop (*)), ("/", divop),
           ("%", binop (\ x y -> fromInteger (round x `rem` round y))),
           ("not", Fun (\ (Bool b) -> unitM (Bool (not b)))), 
           ("==", binop2 (==)), ("/=", binop2 (/=)),
           (">", binop2 (>)), (">=", binop2 (>=)),
           ("<", binop2 (<)), ("<=", binop2 (<=)),
           ("True", Bool True), ("False", Bool False),
	   ("Unit", Unit), ("isUnit", myIsUnit), 
           ("pair", myPair), ("fst", myFst), ("snd", mySnd), 
           ("cons", myPair), ("car", myFst), ("cdr", mySnd), ("nil", Unit),
           ("isPair", myIsPair), ("isCons", myIsPair), 
           ("triple", myTriple),
           ("fst3", myFst3), ("snd3", mySnd3), ("thd3", myThd3),
           ("++", myStrAppend), ("toString", myToString) 
          ]


fst3 :: (a, b, c) -> a
fst3 (a, b, c) = a

run :: String -> String
run str = showValue ((fst3 . snd) (interp (myParse str) initEnv
                                  (\ v (_, y, z) -> ((), (v, y, z))) (Unit, Unit, Unit)))
main :: IO ()
main = interact run

load :: String -> IO ()
load path = readFile path >>= \ prog ->
   	    putStrLn (run prog)

load0 :: String -> IO ()
load0 path = readFile path >>= \ prog ->
    	     putStr (show (myParse prog))

-- for example,
{- 
  run ("let fact = \\ n ->            "++
       "  begin                       "++
       "    setX 1; setY n;           "++
       "    while getY > 0 do begin   "++
       "      let r = getX in 	      "++     
       "      let n = get inY 	      "++
       "      setX (r*n); setY (n-1); "++
       "    end;                      "++
       "    getX;                     "++
       "  end in                      "++
       "setX (fact 9)")
 -}