import Monad
import Maybe
import Lang

-- prerusovani vypoctu po kazde zmene

data Result x = Chyba String | Hodnota x deriving (Show)

instance Monad Result where
  Chyba s >>=  _ = Chyba s
  Hodnota a >>= f = f a
  return x = Hodnota x
  fail s = Chyba s

type Stream w = [w]->[w]

-- v kazdem kroku bud zkoncime s nejakym vysledkem, nebo pokracujeme dalsim vypoctem
-- tomuto vypoctu je mozne poslat jiny/pozmeneny stav/vystup
data Vypocet w s x = V ((s,Stream w)->(s, Stream w, Either (Result x) (String, Vypocet w s x)))
unV (V vyp) = vyp

instance Monad (Vypocet w s) where
  V vyp1 >>= f = V spoj
    where
      spoj stav = let (stav', w', val) = vyp1 stav
                   in case val of
		        Left (Chyba ch) -> (stav', w', Left (Chyba ch))
			Left (Hodnota x) -> unV (f x) (stav', w')
			Right (duvod, comp) -> (stav', w', Right (duvod, comp >>= f))
  return x = V (\(s,w) -> (s,w,Left (return x)))
  fail ch = V (\(s,w) -> (s,w,Left (fail ch)))

instance MonadPlus (Vypocet w s) where
 V f1 `mplus` V f2 = V spoj
   where
     spoj (s, w) = let (s', w', r') = f1 (s, w) in
                      case r' of
		        Left (Chyba _) -> f2 (s', w')
			Left (Hodnota _) -> (s', w', r')
			Right (duvod, comp) -> (s', w', Right (duvod, comp `mplus` V f2))
 mzero = V (\(s,w)->(s,w,Left (fail "mzero")))

class MonadRead m s | m -> s where
  get :: m s

instance MonadRead (Vypocet w s) s where
  get = V (\(s,w) -> (s,w,Left (return s)))

class MonadState m s | m -> s where
  put :: s -> m ()

instance MonadState (Vypocet w s) s where
  put s = V (\(_,w) -> (s,w,Left (return ())))

class MonadWrite m w | m -> w where
  write :: w -> m ()

instance MonadWrite (Vypocet w s) w where
  write w = V (\(s, ws) -> (s, ws . (w:), Left (return ())))

class MonadStop m where
  stop :: String->m ()

instance MonadStop (Vypocet w s) where
  stop duvod = V (\(s,w)->(s,w,Right (duvod, return ())))

runVypocetH :: (Show s, Show w, Show x) => Vypocet w s x -> s -> Stream w -> Integer -> IO ()
runVypocetH (V f) state ws step =
  do
    putStrLn ("Step " ++ show step)
    putStrLn ("  state " ++ show state')
    putStrLn ("  output " ++ show (ws' []))
    case r of
      Left vys -> putStrLn ("Result: " ++ show vys)
      Right (duvod,next) -> 
         do
	   putStrLn ("  " ++ duvod)
	   runVypocetH next state' ws' (step + 1)
  where
    (state', ws', r) = f (state, ws)

runVypocet :: (Show s, Show w, Show x) => Vypocet w s x -> s -> IO ()
runVypocet v state = runVypocetH v state id 1

eval::(Monad m, MonadPlus m, MonadStop m, MonadRead m Values, MonadState m Values, MonadWrite m Integer) => Expr->m Integer
eval (Plus e1 e2) = 
  do
   r1 <- eval e1
   r2 <- eval e2
   return (r1 + r2)
eval (Minus e1 e2) =
  do
   r1 <- eval e1
   r2 <- eval e2
   return (r1 - r2)
eval (Mul e1 e2) = 
  do
   r1 <- eval e1
   r2 <- eval e2
   return (r1 * r2)
eval (Div e1 e2) =
  do
   r1 <- eval e1
   r2 <- eval e2
   if r2 == 0 then fail "Deleni nulou" else return (r1 `div` r2)
eval (Mod e1 e2) =
  do
   r1 <- eval e1
   r2 <- eval e2 
   if r2 == 0 then fail "Deleni nulou" else return (r1 `mod` r2)
eval (Negate e) =
  do
   r <- eval e
   return (negate r)
eval (Num n) = return n
eval (Var s) =
  do
    ohodnoceni <- get
    case lookup s ohodnoceni of
      Just x -> return x
      Nothing -> fail ("Neznama promenna " ++ s)
eval (Assign s e) =
  do
    r <- eval e
    ohodnoceni <- get
    put (update ohodnoceni s r)
    stop ("prirazeni do promenne " ++ s)
    return r
eval (Output e) =
  do
    r <- eval e
    write r
    stop ("vystup hodnoty " ++ show r)
    return r
eval (Try e1 e2) =
  eval e1 `mplus` (stop "zotaveni z chyby" >> eval e2)

update::Values->Variable->Integer->Values
update [] s v = [(s,v)]
update ((s1,v1):t) s v
  | s == s1 = (s,v) : t
  | otherwise = (s1, v1) : update t s v