summaryrefslogtreecommitdiff
path: root/bf.hs
blob: 619707bdfc77e6d8fa23ac579974a5f3af5ba755 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
import Text.Parsec
import Text.Parsec.String
import Control.Monad.State
import qualified Data.IntMap as M
import Data.Word
import System.Environment
import System.Console.GetOpt
import System.Exit
import Data.Maybe

data BFInstruction = GoBack | GoForward | Increment | Decrement | Input
                   | Output | Loop [BFInstruction]
                   deriving (Show)

parseBack, parseForward, parseIncrement, parseLoop,
 parseDecrement, parseInput, parseOutput :: Parser BFInstruction

parseGen :: Char -> BFInstruction -> Parser BFInstruction
parseGen x y = char x >> return y

parseBack = parseGen '<' GoBack
parseForward = parseGen '>' GoForward
parseIncrement = parseGen '+' Increment
parseDecrement = parseGen '-' Decrement
parseInput = parseGen ',' Input
parseOutput = parseGen '.' Output

parseLoop = do
  char '['
  insn <- parseInstructions
  char ']'
  return $ Loop insn

parseComment :: Parser ()
parseComment = do
  many $ noneOf "<>+-,.[]"
  return ()

parseInstruction :: Parser BFInstruction
parseInstruction = do
  parseComment
  i <- parseBack <|> parseForward <|> parseIncrement <|> parseDecrement
       <|> parseInput <|> parseOutput <|> parseLoop
  parseComment
  return i

parseInstructions :: Parser [BFInstruction]
parseInstructions = many parseInstruction

type BFRunner = StateT (Int, M.IntMap Word8) IO ()

zeroise :: Maybe Word8 -> Word8
zeroise = maybe 0 id

runInstruction :: BFInstruction -> BFRunner

runInstruction GoBack = modify (\(h,m) -> (h-1, m))
runInstruction GoForward = modify (\(h,m) -> (h+1, m))
runInstruction Increment = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  put (bfHead, M.insert bfHead (val + 1) bfMap)
runInstruction Decrement = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  put (bfHead, M.insert bfHead (val - 1) bfMap)
runInstruction Input = do
  (bfHead, bfMap) <- get
  c <- liftIO getChar
  put (bfHead, M.insert bfHead (fromIntegral (fromEnum c)) bfMap)
runInstruction Output = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  liftIO $ putChar $ toEnum $ fromIntegral val
runInstruction loop@(Loop insns) = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  case val of
    0 -> return ()
    _ -> runInstructions insns >> runInstruction loop

runInstructions :: [BFInstruction] -> BFRunner
runInstructions = mapM_ runInstruction

--------------------- Options --------------------------------
data Action = ParseOnly | Interpret deriving (Show, Eq)

data Options = Options
               { optHelp :: Bool
               , optVersion :: Bool
               , optAction :: Action
               }
               deriving (Show)

defaultOptions :: Options
defaultOptions =
  Options { optHelp = False
          , optVersion = False
          , optAction = Interpret
          }

options :: [OptDescr (Options -> Options)]
options = [ Option ['v']     ["version"]
            (NoArg (\ opts -> opts { optVersion = True }))
            "show the version of the bf interpreter"
          , Option ['h']     ["help"]
            (NoArg (\ opts -> opts { optHelp = True }))
            "show help for the bf interpreter"
          , Option ['p']     ["parse"]
            (NoArg (\ opts -> opts { optAction = ParseOnly }))
            "parse the input and display it"
          , Option ['i']     ["interpret"]
            (NoArg (\ opts -> opts { optAction = Interpret }))
            "parse the input and interpret it"
          ]

usage :: String
usage = usageInfo header options
  where
    header = "Usage: bf [OPTION...] filename\n\n"

bfOptions :: [String] -> IO (Options, Maybe String)
bfOptions argv =
  case getOpt Permute options argv of
    (o, [n], []  ) -> return (foldl (flip id) defaultOptions o, Just n)
    (o, _,   []  ) -> return (foldl (flip id) defaultOptions o, Nothing)
    (_, _,   errs) -> ioError $ userError $ concat errs ++ usage

main :: IO ()
main = do
  argv <- getArgs
  (opts, fname) <- bfOptions argv

  when (optVersion opts) $ do
    putStrLn "bf Version 1"
    exitSuccess
  when (optHelp opts) $ do
    putStrLn usage
    exitSuccess
  when (fname == Nothing) $ do
    putStrLn "You must supply exactly one file name to bf\n"
    putStrLn usage
    exitFailure
  let fname' = fromJust fname
  let action = optAction opts
  cont <- readFile fname'
  case parse parseInstructions fname' cont of
    Left e -> print e
    Right insns -> do
      if action == ParseOnly
        then print insns
        else evalStateT (runInstructions insns) (0, M.empty)