From 75d7d5c87cef6781870de04e1ff39cdc2a94102f Mon Sep 17 00:00:00 2001 From: Logan McGrath Date: Wed, 25 Aug 2021 07:58:48 -0700 Subject: [PATCH] Cleaning up for clean slate, adding tests --- app/Main.hs | 3 +- helloworld.txt | 12 +- hie.yaml | 3 + package.yaml | 44 +---- src/TuringHS.hs | 10 +- src/TuringHS/Compiler.hs | 18 -- src/TuringHS/Interpreter.hs | 211 +-------------------- src/TuringHS/{Operation.hs => Operator.hs} | 18 +- src/TuringHS/Parser.hs | 13 ++ test/TuringHS/OperatorSpec.hs | 37 ++++ test/TuringHS/ParserSpec.hs | 21 ++ turing-hs.cabal | 136 +------------ 12 files changed, 121 insertions(+), 405 deletions(-) delete mode 100644 src/TuringHS/Compiler.hs rename src/TuringHS/{Operation.hs => Operator.hs} (74%) create mode 100644 src/TuringHS/Parser.hs create mode 100644 test/TuringHS/OperatorSpec.hs create mode 100644 test/TuringHS/ParserSpec.hs diff --git a/app/Main.hs b/app/Main.hs index f203af6..2981170 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,4 +6,5 @@ main :: IO () main = do input <- readFile "helloworld.txt" putStrLn "Running the program!" - interpret (compile input) + machine <- interpret (parse input) + putStrLn $ "The final state of the machine is " ++ show machine diff --git a/helloworld.txt b/helloworld.txt index 0471850..3acacd3 100644 --- a/helloworld.txt +++ b/helloworld.txt @@ -1,5 +1,13 @@ -This program prints "Hello World!" and a newline to the screen, its -length is 106 active command characters (it is not the shortest) +[ This program prints "Hello World!" and a newline to the screen, its + length is 106 active command characters. [It is not the shortest.] + + This loop is an "initial comment loop", a simple way of adding a comment + to a BF program such that you don't have to worry about any command + characters. Any ".", ",", "+", "-", "<" and ">" characters are simply + ignored, the "[" and "]" characters just have to be balanced. This + loop and the commands it contains are ignored because the current cell + defaults to a value of 0; the 0 value causes this loop to be skipped. +] ++++++++ Set Cell #0 to 8 [ >++++ Add 4 to Cell #1; this will always set Cell #1 to 4 diff --git a/hie.yaml b/hie.yaml index ad740e9..4036c08 100644 --- a/hie.yaml +++ b/hie.yaml @@ -6,5 +6,8 @@ cradle: - path: "./app/Main.hs" component: "turing-hs:exe:turing" + - path: "./app/Paths_turing_hs.hs" + component: "turing-hs:exe:turing" + - path: "./test" component: "turing-hs:test:turing-hs-test" diff --git a/package.yaml b/package.yaml index 1a8375b..b44173a 100644 --- a/package.yaml +++ b/package.yaml @@ -30,6 +30,7 @@ tests: - -rtsopts - -with-rtsopts=-N dependencies: + - hspec - turing-hs ghc-options: @@ -40,52 +41,9 @@ ghc-options: - -Wincomplete-patterns - -Wincomplete-record-updates - -Wincomplete-uni-patterns - - -Wmissing-deriving-strategies - -Wmissing-home-modules - -Wname-shadowing - -Wpartial-fields - -Wredundant-constraints - -Wunused-packages - -Wunused-type-patterns - -default-extensions: - - BangPatterns - - BinaryLiterals - - BlockArguments - - ConstraintKinds - - DataKinds - - DefaultSignatures - - DeriveDataTypeable - - DeriveFoldable - - DeriveFunctor - - DeriveGeneric - - DeriveTraversable - - DerivingStrategies - - DoAndIfThenElse - - EmptyDataDecls - - ExistentialQuantification - - FlexibleContexts - - FlexibleInstances - - FunctionalDependencies - - GADTs - - GeneralizedNewtypeDeriving - - InstanceSigs - - KindSignatures - - LambdaCase - - MultiParamTypeClasses - - MultiWayIf - - NamedFieldPuns - - OverloadedStrings - - PartialTypeSignatures - - PatternGuards - - PatternSynonyms - - PolyKinds - - RankNTypes - - RecordWildCards - - ScopedTypeVariables - - StandaloneDeriving - - TemplateHaskell - - TupleSections - - TypeFamilies - - TypeSynonymInstances - - ViewPatterns diff --git a/src/TuringHS.hs b/src/TuringHS.hs index e6eaa70..6fb1349 100644 --- a/src/TuringHS.hs +++ b/src/TuringHS.hs @@ -1,10 +1,10 @@ module TuringHS - ( module TuringHS.Compiler, - module TuringHS.Operation, - module TuringHS.Interpreter, + ( module TuringHS.Interpreter, + module TuringHS.Operator, + module TuringHS.Parser, ) where -import TuringHS.Compiler import TuringHS.Interpreter -import TuringHS.Operation +import TuringHS.Operator +import TuringHS.Parser diff --git a/src/TuringHS/Compiler.hs b/src/TuringHS/Compiler.hs deleted file mode 100644 index 77be503..0000000 --- a/src/TuringHS/Compiler.hs +++ /dev/null @@ -1,18 +0,0 @@ -module TuringHS.Compiler where - -import TuringHS.Operation - -compile :: String -> [Operation] -compile = go [] - where - go ops (c : cs) = case c of - '<' -> go (Backward : ops) cs - '>' -> go (Forward : ops) cs - '+' -> go (Increment : ops) cs - '-' -> go (Decrement : ops) cs - '.' -> go (Put : ops) cs - ',' -> go (Get : ops) cs - '[' -> go (JumpForward : ops) cs - ']' -> go (JumpBackward : ops) cs - _ -> go ops cs - go ops [] = reverse ops diff --git a/src/TuringHS/Interpreter.hs b/src/TuringHS/Interpreter.hs index 8d18171..6ff633f 100644 --- a/src/TuringHS/Interpreter.hs +++ b/src/TuringHS/Interpreter.hs @@ -1,210 +1,11 @@ -{-# LANGUAGE TupleSections #-} - module TuringHS.Interpreter where -import Control.Monad -import TuringHS.Operation +import TuringHS.Operator -------------------------------------------------------------------------------- --- Wrapping increment/decrement -------------------------------------------------------------------------------- +data TuringMachine = TuringMachne {} -increment :: (Eq n, Bounded n, Enum n) => n -> n -increment x - | x == maxBound = minBound - | otherwise = succ x +instance Show TuringMachine where + show _ = "TuringMachine is empty!" -decrement :: (Eq n, Bounded n, Enum n) => n -> n -decrement x - | x == minBound = maxBound - | otherwise = pred x - -------------------------------------------------------------------------------- --- State Monad -------------------------------------------------------------------------------- - -newtype State s m a = State {runState :: s -> m (a, s)} - -state :: (s -> m (a, s)) -> State s m a -state = State - -get :: (Monad m) => State s m s -get = State \s -> return (s, s) - -put :: (Monad m) => s -> State s m () -put s = State \_ -> return ((), s) - -instance (Monad m) => Functor (State s m) where - fmap f (State g) = State \s0 -> do - (x1, s1) <- g s0 - return (f x1, s1) - -instance (Monad m) => Applicative (State s m) where - pure x = State \s -> pure (x, s) - State f <*> State g = State \s0 -> do - (f1, s1) <- f s0 - (x2, s2) <- g s1 - return (f1 x2, s2) - -instance (Monad m) => Monad (State s m) where - State h >>= f = State \s0 -> do - (x1, s1) <- h s0 - let State g = f x1 - g s1 - -------------------------------------------------------------------------------- --- Tape Deck -------------------------------------------------------------------------------- - -data TapeDeck a = TapeDeck [a] [a] - -tapeHead :: TapeDeck a -> a -tapeHead = \case - TapeDeck (x : _) _ -> x - _ -> error "Empty tape!" - -headOption :: TapeDeck a -> Maybe a -headOption = \case - TapeDeck (x : _) _ -> Just x - _ -> Nothing - -withHead :: (a -> a) -> TapeDeck a -> TapeDeck a -withHead f = \case - TapeDeck (x : front) back -> TapeDeck (f x : front) back - x -> x - -forwardExtend :: (Bounded a) => TapeDeck a -> TapeDeck a -forwardExtend = \case - TapeDeck (x : front) back -> TapeDeck front (x : back) - TapeDeck [] back -> TapeDeck [minBound] back - -backwardExtend :: (Bounded a) => TapeDeck a -> TapeDeck a -backwardExtend = \case - TapeDeck front (x : back) -> TapeDeck (x : front) back - TapeDeck front [] -> TapeDeck (minBound : front) [] - -forward :: TapeDeck a -> TapeDeck a -forward = \case - TapeDeck (x : front) back -> TapeDeck front (x : back) - _ -> error "Read past the end of the tape!" - -backward :: TapeDeck a -> TapeDeck a -backward = \case - TapeDeck front (x : back) -> TapeDeck (x : front) back - _ -> error "Read past the start of the tape!" - -endOfTape :: TapeDeck a -> Bool -endOfTape = \case - TapeDeck (_ : _) _ -> False - _ -> True - -------------------------------------------------------------------------------- --- Turing Machine -------------------------------------------------------------------------------- - -class (Monad m) => TuringEffect m n where - readData :: m n - storeData :: n -> m () - buffer :: m [n] - -data TuringMachine a = TuringMachine - { turingOps :: TapeDeck Operation, - turingTape :: TapeDeck a, - turingLoop :: Int - } - -runMachine :: forall m n. (TuringEffect m n, Eq n, Enum n, Bounded n) => [Operation] -> m [n] -runMachine ops = runState step machine >> buffer - where - machine :: TuringMachine n - machine = - TuringMachine - { turingOps = TapeDeck ops [], - turingTape = TapeDeck [minBound] [], - turingLoop = 0 - } - -step :: (TuringEffect m n, Eq n, Enum n, Bounded n) => State (TuringMachine n) m () -step = tryRunOp . turingOps =<< get - where - tryRunOp ops - | endOfTape ops = return () - | otherwise = runOp (tapeHead ops) >> step - runOp = \case - Forward -> forwardOp - Backward -> backwardOp - Increment -> incrementOp - Decrement -> decrementOp - Put -> putOp - Get -> getOp - JumpForward -> jumpForwardOp - JumpBackward -> jumpBackwardOp - -nextOperation :: (Monad m) => State (TuringMachine n) m (Maybe Operation) -nextOperation = do - ops <- turingOps <$> get - return - if endOfTape ops - then Nothing - else Just $ tapeHead ops - -forwardOp :: (Bounded n, Monad m) => State (TuringMachine n) m () -forwardOp = withTape forwardExtend - -backwardOp :: (Bounded n, Monad m) => State (TuringMachine n) m () -backwardOp = withTape backwardExtend - -withTape :: (Monad m) => (TapeDeck n -> TapeDeck n) -> State (TuringMachine n) m () -withTape f = do - machine <- get - let turingTape' = f $ turingTape machine - put $ machine {turingTape = turingTape'} - -incrementOp :: (Monad m, Eq n, Enum n, Bounded n) => State (TuringMachine n) m () -incrementOp = withTapeHead increment - -decrementOp :: (Monad m, Eq n, Enum n, Bounded n) => State (TuringMachine n) m () -decrementOp = withTapeHead decrement - -withTapeHead :: (Monad m) => (n -> n) -> State (TuringMachine n) m () -withTapeHead f = do - machine <- get - let turingTape' = withHead f (turingTape machine) - put $ machine {turingTape = turingTape'} - -putOp :: State (TuringMachine n) m () -putOp = undefined - -getOp :: State (TuringMachine n) m () -getOp = undefined - -jumpForwardOp :: (Monad m, Eq n, Bounded n) => State (TuringMachine n) m () -jumpForwardOp = do - withLoop succ - x <- readHead - when (x /= minBound) undefined -- skip to next matching jump backward op - -jumpBackwardOp :: (Monad m, Eq n, Bounded n) => State (TuringMachine n) m () -jumpBackwardOp = do - withLoop pred - x <- readHead - when (x /= minBound) undefined -- skip back to the previous matching jump backward op - -readHead :: (Monad m) => State (TuringMachine n) m n -readHead = tapeHead . turingTape <$> get - -getLoopLevel :: (Monad m) => State (TuringMachine n) m Int -getLoopLevel = turingLoop <$> get - -withLoop :: (Monad m) => (Int -> Int) -> State (TuringMachine n) m () -withLoop f = do - machine <- get - let loop = turingLoop machine - put $ machine {turingLoop = f loop} - return () - -withOps :: (Monad m) => (TapeDeck Operation -> TapeDeck Operation) -> State (TuringMachine n) m () -withOps f = do - machine <- get - let turingOps' = f $ turingOps machine - put $ machine {turingOps = turingOps'} +interpret :: [Operator] -> m TuringMachine +interpret = undefined diff --git a/src/TuringHS/Operation.hs b/src/TuringHS/Operator.hs similarity index 74% rename from src/TuringHS/Operation.hs rename to src/TuringHS/Operator.hs index 1a736fa..b5bb34d 100644 --- a/src/TuringHS/Operation.hs +++ b/src/TuringHS/Operator.hs @@ -1,6 +1,6 @@ -module TuringHS.Operation where +module TuringHS.Operator where -data Operation +data Operator = -- | ">" Increment the data pointer (to point to the next cell to the right). Forward | -- | "<" Decrement the data pointer (to point to the next cell to the left). @@ -22,4 +22,16 @@ data Operation -- the instruction pointer forward to the next command, jump it back to the -- command after the matching [ command. JumpBackward - deriving stock (Eq, Show) + deriving (Eq, Show) + +getOperator :: Char -> Maybe Operator +getOperator c = case c of + '>' -> Just Forward + '<' -> Just Backward + '+' -> Just Increment + '-' -> Just Decrement + '.' -> Just Put + ',' -> Just Get + '[' -> Just JumpForward + ']' -> Just JumpBackward + _ -> Nothing diff --git a/src/TuringHS/Parser.hs b/src/TuringHS/Parser.hs new file mode 100644 index 0000000..1bf47dc --- /dev/null +++ b/src/TuringHS/Parser.hs @@ -0,0 +1,13 @@ +module TuringHS.Parser where + +import Control.Monad +import Data.Char +import Data.Maybe +import TuringHS.Operator + +parse :: String -> [Operator] +parse = parseLine <=< lines + where + parseLine = takeJusts . fmap getOperator . stripSpaces + stripSpaces = filter (not . isSpace) + takeJusts = fmap fromJust . takeWhile isJust diff --git a/test/TuringHS/OperatorSpec.hs b/test/TuringHS/OperatorSpec.hs new file mode 100644 index 0000000..930153d --- /dev/null +++ b/test/TuringHS/OperatorSpec.hs @@ -0,0 +1,37 @@ +module TuringHS.OperatorSpec where + +import Data.Foldable +import Test.Hspec +import TuringHS.Operator + +spec :: Spec +spec = do + describe "getOperator" $ do + describe "happy-path" $ do + it "should get Forward from '>'" $ do + getOperator '>' `shouldBe` Just Forward + it "should get Backward from '<" $ do + getOperator '<' `shouldBe` Just Backward + it "should get Increment from '+'" $ do + getOperator '+' `shouldBe` Just Increment + it "should get Decrement from '-'" $ do + getOperator '-' `shouldBe` Just Decrement + it "should get Put from '.'" $ do + getOperator '.' `shouldBe` Just Put + it "should get Get from ','" $ do + getOperator ',' `shouldBe` Just Get + it "should get JumpForward from '['" $ do + getOperator '[' `shouldBe` Just JumpForward + it "should get JumpBackward from ']'" $ do + getOperator ']' `shouldBe` Just JumpBackward + + describe "unhappy-path" $ do + traverse_ makeBadExample badInput + +badInput :: String +badInput = ['a' .. 'z'] ++ ['0' .. '9'] ++ ['@', '$', ' ', '\n', '\t'] + +makeBadExample :: Char -> SpecWith () +makeBadExample input = do + it ("should not get anything from " ++ show input) $ do + getOperator input `shouldBe` Nothing diff --git a/test/TuringHS/ParserSpec.hs b/test/TuringHS/ParserSpec.hs new file mode 100644 index 0000000..d171421 --- /dev/null +++ b/test/TuringHS/ParserSpec.hs @@ -0,0 +1,21 @@ +module TuringHS.ParserSpec where + +import Test.Hspec +import TuringHS.Operator +import TuringHS.Parser + +spec :: Spec +spec = do + describe "parse" $ do + it "should accept operators until reaching non-operator input" $ do + let lineWithBadInput = ",.<>[]banana][.,>" + parse lineWithBadInput `shouldBe` [Get, Put, Backward, Forward, JumpForward, JumpBackward] + it "should accept operators from the start of lines until non-operator input" $ do + let lines' = + unlines + [ ",.<>banana[],>>>>garbage", + "[ maybe label where this goes", + " and then you can write a novel here...", + "] that other jump comes here" + ] + parse lines' `shouldBe` [Get, Put, Backward, Forward, JumpForward, JumpBackward] diff --git a/turing-hs.cabal b/turing-hs.cabal index 19f3bd1..04ee0e9 100644 --- a/turing-hs.cabal +++ b/turing-hs.cabal @@ -13,55 +13,14 @@ extra-source-files: library exposed-modules: TuringHS - TuringHS.Compiler TuringHS.Interpreter - TuringHS.Operation + TuringHS.Operator + TuringHS.Parser other-modules: Paths_turing_hs hs-source-dirs: src - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DoAndIfThenElse - EmptyDataDecls - ExistentialQuantification - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedStrings - PartialTypeSignatures - PatternGuards - PatternSynonyms - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeFamilies - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns build-depends: base >=4.7 && <5 default-language: Haskell2010 @@ -72,48 +31,7 @@ executable turing Paths_turing_hs hs-source-dirs: app - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DoAndIfThenElse - EmptyDataDecls - ExistentialQuantification - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedStrings - PartialTypeSignatures - PatternGuards - PatternSynonyms - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeFamilies - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , turing-hs @@ -123,52 +41,14 @@ test-suite turing-hs-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + TuringHS.OperatorSpec + TuringHS.ParserSpec Paths_turing_hs hs-source-dirs: test - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DoAndIfThenElse - EmptyDataDecls - ExistentialQuantification - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedStrings - PartialTypeSignatures - PatternGuards - PatternSynonyms - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeFamilies - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , hspec , turing-hs default-language: Haskell2010