Initial commit

.gitignore

@@ -0,0 +1,2 @@
+/dist-newstyle
+/result

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for bf-repl
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2022 h7x4 <h7x4@nani.wtf>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

README.md

@@ -0,0 +1,13 @@
+[![built with nix](https://builtwithnix.org/badge.svg)](https://builtwithnix.org)
+
+# bf-repl
+
+A modern REPL for BrainFuck, written in Haskell
+
+This REPL will let you:
+
+- [ ] Run bf commands interactively
+- [ ] Execute bf scripts
+- [X] Inspect the stack
+- [ ] Create and save macros
+- [ ] Format and color highlight bf code

bf-repl.cabal

@@ -0,0 +1,42 @@
+cabal-version:      2.4
+name:               bf-repl
+version:            0.1.0.0
+
+synopsis: A modern REPL for BrainFuck, written in Haskell
+
+homepage:           https://git.nani.wtf/h7x4/bf-repl
+bug-reports:        https://git.nani.wtf/h7x4/bf-repl/issues
+
+license:            MIT
+license-file:       LICENSE
+
+author:             h7x4 <h7x4@nani.wtf>
+maintainer:         h7x4 <h7x4@nani.wtf>
+
+category: Language, 
+extra-source-files: CHANGELOG.md
+
+source-repository head
+    type:     git
+    location: git://git.nani.wtf/h7x4/bf-repl.git
+
+executable bf-repl
+    main-is: Main.hs
+    other-modules:
+        Base
+      , Evaluate
+      , Formatter
+      , Memory
+      , Parser
+      , REPL
+
+    other-extensions:
+        OverloadedStrings
+      , NamedFieldPuns
+    build-depends:
+        base ^>= 4.16.3.0
+      , hashmap ^>= 1.3.3
+      , text ^>= 2.0.0
+      , repline ^>= 0.4.2
+    hs-source-dirs:   src
+    default-language: Haskell2010

flake.lock

@@ -0,0 +1,26 @@
+{
+  "nodes": {
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1663587673,
+        "narHash": "sha256-4C4R/PV8+HjkgVd1Db8AuvHwhQp5vllVqOQEl6YDh3o=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "20dc478985d6545df53f0153f4af125eb014083d",
+        "type": "github"
+      },
+      "original": {
+        "id": "nixpkgs",
+        "ref": "nixos-22.05",
+        "type": "indirect"
+      }
+    },
+    "root": {
+      "inputs": {
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,70 @@
+{
+  description = "My haskell project";
+
+  inputs.nixpkgs.url = "nixpkgs/nixos-22.05";
+
+  outputs = { self, nixpkgs }: let
+    packageName = "bf-repl";
+    compiler = "ghc924";
+
+    supportedSystems = [ "x86_64-linux" "x86_64-darwin" ];
+
+    haskellOverlay = (final: prev: {
+      haskellPackages = let
+        hpkgs = prev.haskell.packages.${compiler};
+        inherit (prev.lib.trivial) flip pipe;
+        inherit (prev.haskell.lib)
+          appendPatch
+          appendConfigureFlags
+          dontCheck
+          dontHaddock
+          doJailbreak;
+      in hpkgs.override {
+        overrides = hpFinal: hpPrev: {
+          Cabal = hpPrev.Cabal_3_6_3_0;
+          text = hpPrev.text_2_0;
+          parsec = hpPrev.parsec_3_1_15_1;
+          ${packageName} = doJailbreak (hpkgs.callCabal2nix packageName ./. { }); 
+        };
+      };
+    });
+
+    pkgsForAllSystems = f: nixpkgs.lib.genAttrs supportedSystems (system: let
+      pkgs = import nixpkgs {
+        inherit system;
+        overlays = [ haskellOverlay ];
+      };
+    in f system pkgs);
+
+  in {
+    packages = pkgsForAllSystems (system: pkgs: {
+      ${packageName} = pkgs.haskellPackages.${packageName};
+      default = self.packages.${system}.${packageName};
+    });
+
+    devShells = pkgsForAllSystems (system: pkgs: {
+      default = pkgs.haskellPackages.shellFor {
+        packages = p: [ p.${packageName} ];
+        withHoogle = false;
+        buildInputs = with pkgs.haskellPackages; [
+          cabal-install
+          ghcid
+          haskell-language-server
+          hlint
+        ];
+        shellHook = "export PS1='\\e[1;34m[nix] ${packageName}> \\e[0m'";
+      };
+    });
+
+    apps = pkgsForAllSystems (system: pkgs: {
+      ${packageName} = {
+        program = "${self.packages.${system}.${packageName}}/bin/${packageName}";
+        type = "app";
+      };
+      default = self.apps.${system}.${packageName};
+    });
+
+    hydraJobs = {
+    };
+  };
+}

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