Cleaning up for clean slate, adding tests

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

helloworld.txt

@@ -1,5 +1,13 @@
-This program prints "Hello World!" and a newline to the screen, its
+[ This program prints "Hello World!" and a newline to the screen, its
-length is 106 active command characters (it is not the shortest)
+  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

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"

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

src/TuringHS.hs

@@ -1,10 +1,10 @@
 module TuringHS
-  ( module TuringHS.Compiler,
+  ( module TuringHS.Interpreter,
-    module TuringHS.Operation,
+    module TuringHS.Operator,
-    module TuringHS.Interpreter,
+    module TuringHS.Parser,
   )
 where
 
-import TuringHS.Compiler
 import TuringHS.Interpreter
-import TuringHS.Operation
+import TuringHS.Operator
+import TuringHS.Parser

src/TuringHS/Compiler.hs

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

src/TuringHS/Interpreter.hs

@@ -1,210 +1,11 @@
-{-# LANGUAGE TupleSections #-}
-
 module TuringHS.Interpreter where
 
-import Control.Monad
+import TuringHS.Operator
-import TuringHS.Operation
 
--------------------------------------------------------------------------------
+data TuringMachine = TuringMachne {}
--- Wrapping increment/decrement
--------------------------------------------------------------------------------
 
-increment :: (Eq n, Bounded n, Enum n) => n -> n
+instance Show TuringMachine where
-increment x
+  show _ = "TuringMachine is empty!"
-  | x == maxBound = minBound
-  | otherwise = succ x
 
-decrement :: (Eq n, Bounded n, Enum n) => n -> n
+interpret :: [Operator] -> m TuringMachine
-decrement x
+interpret = undefined
-  | 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'}

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

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

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

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]

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:
+  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
-      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
   build-depends:
       base >=4.7 && <5
   default-language: Haskell2010
@@ -72,48 +31,7 @@ executable turing
       Paths_turing_hs
   hs-source-dirs:
       app
-  default-extensions:
+  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
-      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
   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:
+  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
-      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
   build-depends:
       base >=4.7 && <5
+    , hspec
     , turing-hs
   default-language: Haskell2010