hacking around and maybe I can make state suck less?

.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

README.md

@@ -0,0 +1 @@
+# turing-hs

app/Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import TuringHS
+
+main :: IO ()
+main = do
+  input <- readFile "helloworld.txt"
+  putStrLn "Running the program!"
+  interpret (compile input)

helloworld.txt

@@ -0,0 +1,35 @@
+This program prints "Hello World!" and a newline to the screen, its
+length is 106 active command characters (it is not the shortest)
+++++++++               Set Cell #0 to 8
+[
+    >++++               Add 4 to Cell #1; this will always set Cell #1 to 4
+    [                   as the cell will be cleared by the loop
+        >++             Add 2 to Cell #2
+        >+++            Add 3 to Cell #3
+        >+++            Add 3 to Cell #4
+        >+              Add 1 to Cell #5
+        <<<<-           Decrement the loop counter in Cell #1
+    ]                   Loop until Cell #1 is zero; number of iterations is 4
+    >+                  Add 1 to Cell #2
+    >+                  Add 1 to Cell #3
+    >-                  Subtract 1 from Cell #4
+    >>+                 Add 1 to Cell #6
+    [<]                 Move back to the first zero cell you find; this will
+                        be Cell #1 which was cleared by the previous loop
+    <-                  Decrement the loop Counter in Cell #0
+]                       Loop until Cell #0 is zero; number of iterations is 8
+
+The result of this is:
+Cell no :   0   1   2   3   4   5   6
+Contents:   0   0  72 104  88  32   8
+Pointer :   ^
+
+>>.                     Cell #2 has value 72 which is 'H'
+>---.                   Subtract 3 from Cell #3 to get 101 which is 'e'
++++++++..+++.           Likewise for 'llo' from Cell #3
+>>.                     Cell #5 is 32 for the space
+<-.                     Subtract 1 from Cell #4 for 87 to give a 'W'
+<.                      Cell #3 was set to 'o' from the end of 'Hello'
++++.------.--------.    Cell #3 for 'rl' and 'd'
+>>+.                    Add 1 to Cell #5 gives us an exclamation point
+>++.                    And finally a newline from Cell #6

hie.yaml

@@ -0,0 +1,10 @@
+cradle:
+  stack:
+    - path: "./src"
+      component: "turing-hs:lib"
+
+    - path: "./app/Main.hs"
+      component: "turing-hs:exe:turing"
+
+    - path: "./test"
+      component: "turing-hs:test:turing-hs-test"

package.yaml

@@ -0,0 +1,91 @@
+name:                turing-hs
+version:             0.1.0.0
+
+extra-source-files:
+- README.md
+
+dependencies:
+- base >= 4.7 && < 5
+
+library:
+  source-dirs: src
+
+executables:
+  turing:
+    main: Main.hs
+    source-dirs: app
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - turing-hs
+
+tests:
+  turing-hs-test:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - turing-hs
+
+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
+
+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

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

src/TuringHS/Compiler.hs

@@ -0,0 +1,18 @@
+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

@@ -0,0 +1,210 @@
+{-# LANGUAGE TupleSections #-}
+
+module TuringHS.Interpreter where
+
+import Control.Monad
+import TuringHS.Operation
+
+-------------------------------------------------------------------------------
+-- Wrapping increment/decrement
+-------------------------------------------------------------------------------
+
+increment :: (Eq n, Bounded n, Enum n) => n -> n
+increment x
+  | x == maxBound = minBound
+  | otherwise = succ x
+
+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'}

src/TuringHS/Operation.hs

@@ -0,0 +1,25 @@
+module TuringHS.Operation where
+
+data Operation
+  = -- | ">" 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).
+    Backward
+  | -- | "+" Increment (increase by one) the byte at the data pointer.
+    Increment
+  | -- | "-" Decrement (decrease by one) the byte at the data pointer.
+    Decrement
+  | -- | "." Output the byte at the data pointer.
+    Put
+  | -- | "," Accept one byte of input, storing its value in the byte at the data
+    -- pointer.
+    Get
+  | -- | "[" If the byte at the data pointer is zero, then instead of moving the
+    -- instruction pointer forward to the next command, jump it forward to the
+    -- command after the matching ] command.
+    JumpForward
+  | -- | "]" If the byte at the data pointer is nonzero, then instead of moving
+    -- the instruction pointer forward to the next command, jump it back to the
+    -- command after the matching [ command.
+    JumpBackward
+  deriving stock (Eq, Show)

stack.yaml

@@ -0,0 +1,67 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack.yaml.lock

@@ -0,0 +1,13 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 585817
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
+    sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887
+  original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

turing-hs.cabal

@@ -0,0 +1,174 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+
+name:           turing-hs
+version:        0.1.0.0
+build-type:     Simple
+extra-source-files:
+    README.md
+
+library
+  exposed-modules:
+      TuringHS
+      TuringHS.Compiler
+      TuringHS.Interpreter
+      TuringHS.Operation
+  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
+  build-depends:
+      base >=4.7 && <5
+  default-language: Haskell2010
+
+executable turing
+  main-is: Main.hs
+  other-modules:
+      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
+  build-depends:
+      base >=4.7 && <5
+    , turing-hs
+  default-language: Haskell2010
+
+test-suite turing-hs-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      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
+  build-depends:
+      base >=4.7 && <5
+    , turing-hs
+  default-language: Haskell2010