module Main where
import Prelude as P
import Data.Sequence as S
import Data.Maybe
import Data.Char
import System.IO
import System.Environment
import System.Console.GetOpt
import System.Environment
import Text.ParserCombinators.Parsec as Parsec
data BrainFuck = Incr
| Decr
| MoveLeft
| MoveRight
| Write
| Read
| Proc [BrainFuck]
| CallProc
| Loop [BrainFuck]
deriving (Show)
actions :: [(Char,BrainFuck)]
actions = [('>',MoveRight)
,('<',MoveLeft)
,('+',Incr)
,('-',Decr)
,('.',Write)
,(',',Read)
,(':',CallProc)
]
evalBF :: [BrainFuck]
-> (IO Int)
-> (Int-> IO ())
-> IO (Seq Int,Int,[(Int,[BrainFuck])])
evalBF input readFunc writeFunc =
parse input (singleton 0) 0 []
where parse [] stack ptr proc = return (stack,ptr,proc)
parse (Incr:xs) stack ptr proc =
parse xs (adjust succ ptr stack) ptr proc
parse (Decr:xs) stack ptr proc
| (index stack ptr) > 0 = parse xs (adjust pred ptr stack) ptr proc
| otherwise = parse xs stack ptr proc
parse (MoveRight:xs) stack ptr proc
| ptr + 1 >= S.length stack = parse xs (stack |> 0) (ptr + 1) proc
| otherwise = parse xs stack (ptr + 1) proc
parse (MoveLeft:xs) stack ptr proc
| ptr > 0 = parse xs stack (ptr - 1) proc
| otherwise = parse xs stack ptr proc
parse (Read:xs) stack ptr proc =
do num <- readFunc
parse xs (update ptr num stack) ptr proc
parse (Write:xs) stack ptr proc =
do writeFunc (index stack ptr)
parse xs stack ptr proc
parse input@(Loop body:xs) stack ptr proc
| (index stack ptr) > 0 = do (stackn,ptrn,procn) <- parse body stack ptr proc
parse input stackn ptrn procn
| otherwise = parse xs stack ptr proc
parse (Proc body:xs) stack ptr proc =
parse xs stack ptr (((index stack ptr),body):proc)
parse (CallProc:xs) stack ptr proc =
case (lookup (index stack ptr) proc) of
Nothing -> parse xs stack ptr proc
Just body -> do (stackn,ptrn,procn) <- parse body stack ptr proc
parse xs stackn ptrn procn
writeBF :: Bool -> Int -> IO ()
writeBF isRaw x
| isRaw = putChar (chr $ x)
| otherwise = putStrLn (show $ x)
readBF :: Bool -> IO Int
readBF isRaw = do num <-read
return $ parse num
where read = do putStr "> "
hFlush stdout
getLine
parse input
| isRaw = ord $ head input
| otherwise = fst $ head $ case (reads input :: [(Int,String)]) of
[] -> [(0,"")]
a -> a
bfFile :: GenParser Char () [BrainFuck]
bfFile = do result <- many1 (bfChar <|> bfBraces <|> bfProc <|> (bfTrash >> return []))
eof
return (concat result)
bfProc :: GenParser Char st [BrainFuck]
bfProc = do char '('
result <- many1 (bfChar <|> bfProc <|> bfBraces)
char ')'
return [(Proc (concat result))]
bfBraces :: GenParser Char st [BrainFuck]
bfBraces = do char '['
result <- many1 (bfChar <|> bfBraces <|> bfProc)
char ']'
return [(Loop (concat result))]
bfChar :: GenParser Char st [BrainFuck]
bfChar = do result <- oneOf "><+-,.:"
return [(fromJust $ lookup result actions)]
bfTrash :: Parser Char
bfTrash = noneOf "[]><+-,.:()"
parseBF' :: String -> [BrainFuck]
parseBF' cont = case parse bfFile "(unknown)" cont of
Left _ -> []
Right result -> result
data Flag = IsRawInput
| IsRawOutput
deriving (Eq)
options :: [OptDescr Flag]
options = [ Option ['i'] ["input"] (NoArg IsRawInput) "Sets input mode to RAW"
, Option ['o'] ["output"] (NoArg IsRawOutput) "Sets output mode to RAW"
]
main = do args <- getArgs
(opts,files) <- case getOpt Permute options args of
(o,n,[]) -> return (o,n)
(_,_,errs) -> error $ concat errs ++ usage
handle <- if files == []
then error $ "No file specified\n" ++ usage
else openFile (head files) ReadMode
cont <- hGetContents handle
evalBF (parseBF' cont)
(readBF $ IsRawInput `elem` opts)
(writeBF $ IsRawOutput `elem` opts)
where header = "Usage: bf [OPTIONS...] <file>"
usage = usageInfo header options