Initial commit

src/Base.hs

@@ -0,0 +1,32 @@
+module Base where
+
+import qualified Data.HashMap as HM
+
+data BFAction = MoveRight
+              | MoveLeft
+              | Increment
+              | Decrement
+              | Replace
+              | Print
+              | JumpRight
+              | JumpLeft
+
+type Address = Int
+type CodePosition = Int
+
+type Memory = HM.Map Address Int
+type JumpTable = HM.Map CodePosition CodePosition
+
+data State = State { memory :: Memory
+                   , pointer :: Int
+                   , codePos :: Int
+                   , jumpTable :: JumpTable
+                   }
+  deriving (Show, Read, Eq)
+
+initState :: State
+initState = State { memory = HM.empty
+                  , pointer = 0
+                  , codePos = 0
+                  , jumpTable = HM.empty
+                  }

src/Evaluate.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
+
+module Evaluate where
+
+import Base (State(..), BFAction(..))
+import Memory
+import Formatter
+
+import qualified Data.HashMap as HM
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+type ActionResult = (State, Maybe (IO ()))
+
+processAction :: State -> BFAction -> ActionResult
+processAction s@State {pointer, memory, codePos, jumpTable} instruction = let
+    noIO :: State -> ActionResult
+    noIO s = (s, Nothing)
+
+    jump :: ActionResult
+    jump = case HM.lookup codePos jumpTable of
+             Just jumpTo -> noIO $ s { pointer = jumpTo }
+             Nothing -> (s, Just $ T.putStrLn "ERROR: no matching jump point")
+  in case instruction of
+    MoveRight -> noIO $ s { pointer = pointer + 1 }
+    MoveLeft -> noIO $ s { pointer = pointer - 1 }
+    Increment -> noIO $ s { memory = increment memory pointer }
+    Decrement -> noIO $ s { memory = decrement memory pointer }
+    Replace -> noIO $ s { memory = setMemAdr memory pointer $ getMemAdr memory $ getMemAdr memory pointer }
+    Print -> (s, Just $ prettyPrintState' s)
+    JumpRight -> jump
+    JumpLeft -> jump

src/Formatter.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
+
+module Formatter (
+  prettyFormatState
+, prettyFormatState'
+, prettyPrintState
+, prettyPrintState'
+) where
+
+import Base (State(..), Address)
+import Memory (getMemAdr)
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.String (fromString)
+
+data PrinterConfig = PrinterConfig { cellCountHorizontal :: Int
+                                   , cellRowsAbove :: Int
+                                   , cellRowsBelow :: Int
+                                   }
+  deriving (Read, Show, Eq)
+
+defaultPrinterConfig = PrinterConfig { cellCountHorizontal = 7
+                                     , cellRowsAbove = 0
+                                     , cellRowsBelow = 0
+                                     }
+
+divideBy2IntoInts :: Bool -> Int -> (Int, Int)
+divideBy2IntoInts preferLeft n = if preferLeft then (ceiling x, floor x) else (floor x, ceiling x)
+  where
+    x = fromIntegral n / 2.0
+
+createSideCell :: Bool -> Address -> Int -> T.Text
+createSideCell isLeft addr value = fromString str
+  where
+    topLength = length $ show addr
+    innerLength = length $ show value
+    len = max topLength innerLength
+
+    topLen2 = divideBy2IntoInts True (len - topLength)
+    fstTopSpc = replicate (fst topLen2) '─'
+    sndTopSpc = replicate (snd topLen2) '─'
+
+    innerLen2 = divideBy2IntoInts True (len - innerLength)
+    fstInnerSpc = replicate (fst innerLen2) ' '
+    sndInnerSpc = replicate (snd innerLen2) ' '
+
+    l x = if isLeft then x else ""
+    r x = if isLeft then "" else x
+
+    str = l "┬" ++ fstTopSpc ++ "[" ++ show addr ++ "]" ++ sndTopSpc ++ r "┬" ++ "\n"
+       ++ l "│" ++ " " ++ fstInnerSpc ++ show value ++ sndInnerSpc ++ " " ++ r "│" ++ "\n"
+       ++ l "┴" ++ replicate (len + 2) '─' ++ r "┴"
+
+createLeftCell = createSideCell True
+createRightCell = createSideCell False
+
+createMidCell :: Address -> Int -> T.Text
+createMidCell addr value = fromString str
+  where
+    topLength = length $ show addr
+    innerLength = length $ show value
+    len = max topLength innerLength
+
+    topLen2 = divideBy2IntoInts True (len - topLength)
+    fstTopSpc = replicate (fst topLen2) '─'
+    sndTopSpc = replicate (snd topLen2) '─'
+
+    innerLen2 = divideBy2IntoInts True (len - innerLength)
+    fstInnerSpc = replicate (fst innerLen2) ' '
+    sndInnerSpc = replicate (snd innerLen2) ' '
+
+    str = "╦" ++ fstTopSpc ++ "[" ++ show addr ++ "]" ++ sndTopSpc ++ "╦\n"
+       ++ "║ " ++ fstInnerSpc ++ show value ++ sndInnerSpc ++ " ║\n"
+       ++ "╩" ++ replicate (len + 2) '═' ++ "╩"
+
+mergeTextBlocks :: T.Text -> T.Text -> T.Text
+mergeTextBlocks a b = T.unlines $ zipWith T.append (T.lines a) (T.lines b)
+
+prettyFormatState :: PrinterConfig -> State -> T.Text
+prettyFormatState
+  c@PrinterConfig { cellCountHorizontal, cellRowsAbove, cellRowsBelow }
+  s@State {memory, codePos}
+  = foldl1 mergeTextBlocks cells
+  where
+    cellsAround = divideBy2IntoInts False (cellCountHorizontal - 1)
+
+    fetchCellWithOffset offset = getMemAdr memory $ codePos + offset
+
+    cells :: [T.Text]
+    cells = map (\x -> createLeftCell (codePos + x) (fetchCellWithOffset x)) [(negate (fst cellsAround))..(-1)]
+         ++ [createMidCell codePos (fetchCellWithOffset 0) ]
+         ++ map (\x -> createRightCell (codePos + x) (fetchCellWithOffset x)) [(snd cellsAround)..3]
+
+prettyFormatState' :: State -> T.Text
+prettyFormatState' = prettyFormatState defaultPrinterConfig
+
+prettyPrintState :: PrinterConfig -> State -> IO ()
+prettyPrintState c s = T.putStrLn $ prettyFormatState c s
+
+prettyPrintState' :: State -> IO ()
+prettyPrintState' s = T.putStrLn $ prettyFormatState' s

src/Main.hs

@@ -0,0 +1,17 @@
+module Main where
+
+import Base
+import Evaluate
+import Formatter
+
+import Text.Printf
+import Data.String (fromString)
+
+main :: IO ()
+main = prettyPrintState' s
+  where
+    s :: State
+    s = foldl f initState [Increment, Increment, Increment, MoveRight, Increment]
+
+    f :: State -> BFAction -> State
+    f state action = fst (processAction state action)

src/Memory.hs

@@ -0,0 +1,25 @@
+module Memory where
+
+import Base (Memory)
+
+import qualified Data.HashMap as HM
+
+getMemAdr :: Memory -> Int -> Int
+getMemAdr memory adr = HM.findWithDefault 0 adr memory
+
+setMemAdr :: Memory -> Int -> Int -> Memory
+setMemAdr memory adr val = HM.insert adr val memory
+
+increment :: Memory -> Int -> Memory
+increment memory adr = HM.alter f adr memory
+  where
+    f :: Maybe Int -> Maybe Int
+    f Nothing = Just 1
+    f (Just i) = Just $ i + 1
+
+decrement :: Memory -> Int -> Memory
+decrement memory adr = HM.alter f adr memory
+  where
+    f :: Maybe Int -> Maybe Int
+    f Nothing = Just $ -1
+    f (Just i) = Just $ i - 1

src/Parser.hs

@@ -0,0 +1,82 @@
+module Parser where
+
+import Base
+
+import Data.String (fromString)
+import Control.Applicative
+import qualified Data.Text as T
+
+data ASTNode = MoveRight
+         | MoveLeft
+         | Increment
+         | Decrement
+         | Replace
+         | Print
+         | Loop ASTNode
+
+flattenAST :: [ASTNode] -> [BFAction]
+flattenAST = concatMap f
+  where
+    f (Loop x) = [JumpLeft] ++ process x ++ [JumpRight]
+    f x = [x]
+
+data ParserError
+  = EndOfInput
+  | UnexpectedSymbol Char
+  | Empty
+  deriving (Eq, Show)
+
+newtype Parser a = Parser
+                 { runParser :: T.Text -> Either [ParserError] (a, T.Text)
+                 }
+
+instance Functor Parser where
+  fmap f (Parser x) = Parser run
+    where
+      run input = case x input of
+        Left err -> Left err
+        Right (out, res) -> Right (f out, rest)
+
+instance Applicative Parser where
+  pure a = Parser $ \input -> Right (a, input)
+  Parser x <*> Parser y = Parser run
+    where
+      run input = case x input of
+        Left err -> Left err
+        Right (x', rest) -> case y rest of
+          Left err -> Left err
+          Right (y', rest') -> Right (x' y', rest')
+
+instance Monad Parser where
+  return = pure
+  Parser x >>= y = Parser run
+    where
+      run input = case x input of
+        Left err -> Left err
+        Right (out, rest) ->
+          let Parser x' = y out in x' rest
+
+instance Alternative Parser where
+  empty = Parser $ \_ -> Left [Empty]
+  Parser x <|> Parser y = Parser run
+    where
+      run input = case x input of
+        Right (out, rest) -> Right (out, rest)
+        Left err -> case y input of
+          Right (out, rest) -> Right (out, rest)
+          Left err' -> Left err <> err'
+
+satisfy :: (Char -> Bool) -> Parser T.Text
+satisfy p = Parser run
+  where
+    run "" = Left [EndOfInput]
+    run (x : rest) = if p x then Right (x, rest) else Left [UnexpectedSymbol x]
+
+char :: Char -> Parser T.Text
+char c = satisfy (== c)
+
+string :: T.Text -> Parser T.Text
+string (x:xs) = do
+  y <- char x
+  ys <- string xs
+  return $ T.append x ys

src/REPL.hs

@@ -0,0 +1 @@
+module REPL where