Initial commit

This commit is contained in:
h7x4 2022-10-14 01:06:22 +02:00
commit 36d7774512
Signed by: h7x4
GPG Key ID: 9F2F7D8250F35146
14 changed files with 470 additions and 0 deletions

2
.gitignore vendored Normal file
View File

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

5
CHANGELOG.md Normal file
View File

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

21
LICENSE Normal file
View File

@ -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.

13
README.md Normal file
View File

@ -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

42
bf-repl.cabal Normal file
View File

@ -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

26
flake.lock Normal file
View File

@ -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
}

70
flake.nix Normal file
View File

@ -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 = {
};
};
}

32
src/Base.hs Normal file
View File

@ -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
}

32
src/Evaluate.hs Normal file
View File

@ -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

102
src/Formatter.hs Normal file
View File

@ -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

17
src/Main.hs Normal file
View File

@ -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)

25
src/Memory.hs Normal file
View File

@ -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

82
src/Parser.hs Normal file
View File

@ -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

1
src/REPL.hs Normal file
View File

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