{-# OPTIONS -fglasgow-exts #-}
{-# LANGUAGE BangPatterns, NoMonomorphismRestriction #-}

import Data.Char
import Control.Monad
import Data.List.Zipper as Z
import Control.Monad.Prompt
import Control.Monad.State
import Control.Applicative
import Control.Monad.Maybe
import Control.Monad.Writer
import Data.Monoid
import System.Mem.StableName
type Mem = Zipper Int

update f = flip replace `ap` (f . cursor)

initMem :: Mem
initMem = Zip zeros zeros
zeros = repeat 0

data Bf = Inp
        | Out
        | Inc
        | Dec
        | MovL
        | MovR
        | While [Bf]
  deriving (Eq,Ord,Read,Show)

data BfIO :: * -> * where 
   O :: Int -> BfIO ()
   I :: BfIO Int

input = lift $ prompt I
output = lift . prompt . O

-- ghci> exec (parse helloWorld)
-- Hello World!
-- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)]))
helloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."

execIO_ is = execIO is >> ignore
execIO :: [Bf] -> IO Mem
execIO = runPromptM run . flip execStateT initMem . eval
  where 
    run :: forall a. BfIO a -> IO a
    run (O n) = putChar (chr n)
    run I     = ord <$> getChar

eval :: [Bf] -> StateT Mem (Prompt BfIO) ()
eval = mapM_ eval'

eval' :: Bf -> StateT Mem (Prompt BfIO) ()
eval' Inc        = modify $ update (+1)
eval' Dec        = modify $ update (subtract 1)
eval' MovL       = modify left 
eval' MovR       = modify right 
eval' Inp        = input >>= modify . replace
eval' Out        = gets cursor >>= output
eval' (While xs) = while ((== 0) <$> gets cursor) $ eval xs

while :: (Monad m) => m Bool -> m a -> m ()
while mb act = go
    where go = do b <- mb
                  if b then return () else act >> go

add i = tell [i]

char = do s <- get
          case s of
            [] -> return Nothing
            (x:xs) -> put xs >> return (Just x)
            

listen' m = pass $ do (a,w) <- listen m
                      return ((a,w),const mempty)


stop = mzero
ignore = return ()
parse = execWriter . runStateT (runMaybeT parse')
  where 
    parse' = forever go    
    go = do c <- char
            case c of 
              Nothing -> stop
              Just x -> 
                  case x of         
                    ',' -> add Inp 
                    '.' -> add Out 
                    '+' -> add Inc 
                    '-' -> add Dec 
                    '<' -> add MovL
                    '>' -> add MovR
                    '[' -> do ((),xs) <- listen' $ parse' `mplus` ignore
                              add $ While xs
                    ']' -> stop
                    c   -> ignore