4ea241c...master · ikoHSE/sc-task-3

git.iko.soy/ikoHSE/sc-task-3

on master help sign in

6 files changed+544−113

since splitsnapshots

unifiedsplit

README.md+21 package.yaml+6−1 src/Task.hs+131−103 stack.yaml+18−2 task.cabal+14−4 test/Tests.hs+354−3

README.mdnew file+21

@@ -0,0 +1,21 @@

1+# 🎒📓💻 Task 3

3+**NOTE: If you just fork this repository it will not be graded. Ask your supervisor for a special GitHub classroom URL.**

5+## How to do the task

7+Your task is to write a valid definition for every function declared in `src/Task.hs`. All functions have a comment describing what the function needs to do with some examples.

9+There are predefined tests for you to check your answer. You can look at the tests for some more usage examples in `test/Tests.hs`.

10+

11+After defining all functions you then need to commit **and push** your code to your repository. An automated script will then check your solution and give you feedback as a CI result in your GitHub repository.

12+

13+## FAQ

14+

15+> Can I add extra functions in the `Task.hs` file?

16+

17+Yes, you can, but you can not remove existing functions.

18+

19+> Can I change functions declared in the template?

20+

21+No.

package.yaml+6−1

@@ -2,8 +2,11 @@ name: task

22version: 0.1.0.0

33license: Unlicense

5+default-extensions:

6+ - DerivingStrategies

58dependencies:

6− - base >= 4.7 && < 5

9+ - base

710

811library:

912 source-dirs: src

@@ -15,4 +18,6 @@ tests:

1518 dependencies:

1619 - tasty

1720 - tasty-hspec

21+ - hspec

1822 - task

23+ - QuickCheck

src/Task.hs+131−103

@@ -1,5 +1,11 @@

11module Task

2− ( ErrorState (..),

2+ ( Tape (..),

3+ touchTape,

4+ initializeTape,

5+ shiftTapeL,

6+ shiftTapeR,

7+ ErrorState (..),

8+ executeErrorState,

39 get,

410 put,

511 throwError,

@@ -9,21 +15,18 @@ module Task

915 BFMonad,

1016 readInput,

1117 writeOutput,

12− CommandResult (..),

13− shiftCommandR,

14− shiftCommandL,

1518 shiftDataR,

1619 shiftDataL,

1720 readData,

1821 writeData,

19− readCommand,

22+ BFCommand (..),

2023 executeCommand,

2124 evaluateProgram,

2225 executeProgram,

2326 )

2427where

2528

26−import Data.Char

29+import Data.List (intersperse)

2730

2831-- ____ _____ _ _ _

2932-- | __ )| ___| (_)_ __ | |_ ___ _ __ _ __ _ __ ___| |_ ___ _ __

@@ -66,10 +69,22 @@ data Tape a

6669 tapeValue :: a,

6770 rightTape :: [a]

6871 }

69− deriving (Eq, Ord)

72+ deriving stock (Eq, Ord)

7073

74+-- We need a special instance to handle infinite tapes. The derived

75+-- implementation would go into an infinite loop.

7176instance Show a => Show (Tape a) where

72− show (Tape l c right) = show (reverse (take 5 l)) <> " " <> show c <> " " <> show (take 5 right)

77+ show (Tape l c right) =

78+ "["

79+ <> tapeify (reverse (take 5 l))

80+ <> " { "

81+ <> show c

82+ <> " } "

83+ <> tapeify (take 5 right)

84+ <> "]"

85+ where

86+ tapeify :: Show x => [x] -> String

87+ tapeify = mconcat . intersperse " " . fmap show

7388

7489-- | Creates a tape from a list.

7590--

@@ -77,11 +92,11 @@ instance Show a => Show (Tape a) where

7792--

7893-- >>> initializeTape [1, 5, 8, ...]

7994--

80−-- ◀──┬─────┬─────┬─────┬─────┬──▶

81−-- ... │ │ 1 │ 5 │ 8 │ ...

82−-- ◀──┴─────┴─────┴─────┴─────┴──▶

83−-- ▲

84−-- │

95+-- ┌─────┬─────┬─────┬──▶

96+-- │ 1 │ 5 │ 8 │ ...

97+-- └─────┴─────┴─────┴──▶

98+-- ▲

99+-- │

85100initializeTape :: [a] -> Maybe (Tape a)

86101initializeTape [] = Nothing

87102initializeTape (a : aa) = Just (Tape [] a aa)

@@ -118,20 +133,21 @@ data ErrorState e s a

118133 = ErrorState

119134 {runErrorState :: s -> Either e (a, s)}

120135

136+-- | Executes the state monad and returns the result without returning the

137+-- final state.

138+executeErrorState :: s -> ErrorState e s a -> Either e a

139+executeErrorState = error "TODO: executeErrorState"

140+

121141instance Functor (ErrorState e s) where

122− fmap = error "TODO: Functor (ErrorState e s) - fmap"

142+ fmap = error "TODO: fmap"

123143

124144instance Applicative (ErrorState e s) where

125− pure = error "TODO: Applicative (ErrorState e s) - pure"

126−

127− -- NOTE: State from the left hand side should be passed to the right hand

128− -- side.

129− -- Conversely the state from the right hand side should be the state of the

130− -- output.

131− (<*>) = error "TODO: Applicative (ErrorState e s) - (<*>)"

145+ pure = error "TODO: pure"

146+ (<*>) = error "TODO: <*>"

132147

133148instance Monad (ErrorState e s) where

134− (>>=) = error "TODO: Monad (ErrorState e s) - >>="

149+ (>>=) = error "TODO: >>="

150+ return = error "TODO: return"

135151

136152-- | This operation returns the state that the monad currently contains.

137153get :: ErrorState e s s

@@ -158,130 +174,141 @@ modify = error "TODO: modify"

158174-- |___/_| |_|_|_\___/_||_\__,_\__,_|

159175

160176-- In this section we will implement the specific state we will be using and

161−-- some operations that operate on it within the state monad.

162−

163−type BFCommand = Char

177+-- some operations that work within it.

164178

165179-- | This represents the state of our BF interpreter.

166180data BFState

167181 = BFState

168− { -- | The command tape. It contains the a

169− -- pointer to the command being executed.

170− bfCommandTape :: Tape BFCommand,

171− -- | The data tape.

172− bfDataTape :: Tape Char,

182+ { -- | The data tape.

183+ bfDataTape :: Tape Int,

173184 -- | The input stream of the BF interpreter.

174− bfInput :: [Char],

185+ bfInput :: [Int],

175186 -- | The output stream of the BF interpreter.

176− bfOutput :: [Char]

187+ bfOutput :: [Int]

177188 }

178− deriving (Eq, Show)

189+ deriving stock (Eq, Show)

179190

191+-- | This represents the errors that can occur while executing a BF program.

180192data BFError

181− = NotEnoughInput

182− | DataTapeExhausted

183− deriving (Show, Eq)

193+ = -- | Tried reading input, but the input stream was empty.

194+ NotEnoughInput

195+ | -- | Tried going past the end of the data tape (if it was finite).

196+ DataTapeExhausted

197+ deriving stock (Show, Eq)

184198

199+-- | The monad in which we will interpreting the BF commands.

185200type BFMonad a = ErrorState BFError BFState a

186201

187−-- | This operation should consume one 'Char' from the input stream

202+-- | This operation should consume one element from the input stream

188203-- and return it.

189204--

190−-- Should throw 'NotEnoughInput' error when the input stream is empty.

191−--

192−-- HINT: From now on it would be easier to use `do`-syntax.

193−readInput :: BFMonad Char

205+-- If there is not enough input, it should throw 'NotEnoughInput' error.

206+readInput :: BFMonad Int

194207readInput = error "TODO: readInput"

195208

196−-- | This operation should write one 'Char' to the output stream.

209+-- | This operation should write one element to the output stream.

197210-- This should just prepend the character to the start of the string using the

198211-- `:` (cons) operator.

199−writeOutput :: Char -> BFMonad ()

200−writeOutput = error "TODO: writeOutput"

201−

202−data CommandResult

203− = ExecutionTerminated

204− | ExecutionNotTerminated

205− deriving (Eq, Show)

206−

207−-- | This operations shifts the command pointer to the right.

208−--

209−-- NOTE: The execution of the program ends successfully if the command pointer

210−-- moves past the end of the command tape.

211−--

212−-- For this reason you should not throw an error, and instead return whether the

213−-- execution of the program should be terminated.

214−shiftCommandR :: BFMonad CommandResult

215−shiftCommandR = error "TODO: shiftCommandR"

216−

217−-- | This operations shifts the command pointer to the left.

218−--

219−-- NOTE: The execution of the program ends successfully if the command pointer

220−-- moves past the end of the command tape.

221212--

222−-- For this reason you should not throw an error, and instead return whether the

223−-- execution of the program should be terminated.

224−shiftCommandL :: BFMonad CommandResult

225−shiftCommandL = error "TODO: shiftCommandL"

213+-- This will make writing O(1).

214+writeOutput :: Int -> BFMonad ()

215+writeOutput = error "TODO: writeOutput"

226216

227−-- | This operations shifts the data pointer to the right.

217+-- | This operation shifts the data pointer to the right.

228218--

229219-- NOTE: if the tape has ended, you should throw the 'DataTapeExhausted' error.

230220shiftDataR :: BFMonad ()

231221shiftDataR = error "TODO: shiftDataR"

232222

233−-- | This operations shifts the data pointer to the left.

223+-- | This operation shifts the data pointer to the left.

234224--

235225-- NOTE: if the tape has ended, you should throw the 'DataTapeExhausted' error.

236226shiftDataL :: BFMonad ()

237227shiftDataL = error "TODO: shiftDataL"

238228

239−-- | This operation reads the 'Char' at the data pointer.

240−--

241−-- NOTE: if the input has been exhausted, you should throw the 'NotEnoughInput'

242−-- error.

243−readData :: BFMonad Char

229+-- | This operation reads the element at the data pointer.

230+readData :: BFMonad Int

244231readData = error "TODO: readData"

245232

246−-- | This operation writes the 'Char' to the current data pointer.

247−writeData :: Char -> BFMonad ()

233+-- | This operation writes the element to the current data pointer.

234+writeData :: Int -> BFMonad ()

248235writeData = error "TODO: writeData"

249236

250−readCommand :: BFMonad BFCommand

251−readCommand = error "TODO: readCommand"

252−

253237-- _____ _ _ _ _

254238-- |_ _| |_ ___ (_)_ _| |_ ___ _ _ _ __ _ _ ___| |_ ___ _ _

255239-- | | | ' \/ -_) | | ' \ _/ -_) '_| '_ \ '_/ -_) _/ -_) '_|

256240-- |_| |_||_\___| |_|_||_\__\___|_| | .__/_| \___|\__\___|_|

257241-- |_|

258242

259−-- | Executes one BF command.

260−--

261−-- The command should be read from the function argument, not the monad state.

243+-- | The parsed commands from the BF language.

262244--

263245-- Please have a look at this commands table:

264246-- https://en.wikipedia.org/wiki/Brainfuck#Commands

247+data BFCommand

248+ = -- | 'Loop x' is equivalent to `[x]` in BF. It is essentially a while loop.

249+ Loop [BFCommand]

250+ | -- | The `>` command.

251+ ShiftRight

252+ | -- | The `<` command.

253+ ShiftLeft

254+ | -- | The `+` command.

255+ Increment

256+ | -- | The `-` command.

257+ Decrement

258+ | -- | The `,` command.

259+ ReadInput

260+ | -- | The `.` command.

261+ WriteOutput

262+ deriving stock (Eq, Show)

263+

264+type BFProgram = [BFCommand]

265+

266+prependMaybe :: Maybe a -> [a] -> [a]

267+prependMaybe Nothing aa = aa

268+prependMaybe (Just x) xx = x : xx

269+

270+-- | This is just a helper function.

271+parseProgram' :: String -> (BFProgram, String)

272+parseProgram' "" = ([], "")

273+parseProgram' ('[' : rest) = (Loop innerProgram : outerProgram, s')

274+ where

275+ (innerProgram, s) = parseProgram' rest

276+ (outerProgram, s') = parseProgram' s

277+parseProgram' (']' : rest) = ([], rest)

278+parseProgram' (x : rest) = (command `prependMaybe` restProgram, s)

279+ where

280+ (restProgram, s) = parseProgram' rest

281+ command = case x of

282+ '>' -> pure ShiftRight

283+ '<' -> pure ShiftLeft

284+ '+' -> pure Increment

285+ '-' -> pure Decrement

286+ '.' -> pure WriteOutput

287+ ',' -> pure ReadInput

288+ _ -> Nothing

289+

290+-- | This function parses the given string and returns a sequence of BF

291+-- commands.

292+parseProgram :: String -> BFProgram

293+parseProgram = fst . parseProgram'

294+

295+-- | Executes one BF command.

265296--

266−-- Note: non-command characters are ignored.

267−executeCommand :: BFCommand -> BFMonad CommandResult

297+-- NOTE: You will probably need to call 'evaluateProgram' somewhere in

298+-- this function.

299+executeCommand :: BFCommand -> BFMonad ()

268300executeCommand = error "TODO: executeCommand"

269301

270−-- | This function should evaluate the whole program starting from the current

271−-- command pointer.

272−--

273−-- This will probably be recursive.

274−evaluateProgram :: BFMonad ()

302+-- | This function should evaluate the whole program.

303+evaluateProgram :: BFProgram -> BFMonad ()

275304evaluateProgram = error "TODO: evaluateProgram"

276305

277−-- | This constant just contains the "zero" 'Char' value for your convenience.

278−zeroChar :: Char

279−zeroChar = toEnum 0

280−

281306-- | This constant just contains an infinite empty tape. You can use this as

282307-- the initial data tape.

283−emptyTape :: Tape Char

284−emptyTape = Tape (repeat zeroChar) zeroChar (repeat zeroChar)

308+--

309+-- NOTE: It is infinite.

310+emptyTape :: Tape Int

311+emptyTape = Tape (repeat 0) 0 (repeat 0)

285312

286313-- | In this function you should bring everything together and execute the given

287314-- list of commands.

@@ -292,14 +319,15 @@ emptyTape = Tape (repeat zeroChar) zeroChar (repeat zeroChar)

292319-- produces.

293320--

294321-- NOTE: since the output stream of the program is written backwards, you

295−-- will need to reverse the output stream. (You can use the `reverse` function.)

322+-- will need to reverse the output stream. (You can use the 'reverse' function.)

296323--

297324-- You will need to construct the initial state for the monad, evaluate the

298325-- program from the initial state, and convert the resulting value to the

299326-- appropriate type.

300−--

301−-- You can use these two functions to convert between 'Char' and 'Int':

302−-- ord :: Char -> Int

303−-- chr :: Int -> Char

304−executeProgram :: [BFCommand] -> String -> Maybe String

305−executeProgram = error "TODO: executeProgram"

327+executeProgram ::

328+ -- | The text of the BF program.

329+ String ->

330+ -- | The input to pass into the program.

331+ String ->

332+ Maybe String

333+executeProgram = error "TODO: evaluateProgram"

stack.yaml+18−2

@@ -1,7 +1,23 @@

1−resolver: lts-14.27

1+resolver: lts-24.23

33packages:

44- .

66ghc-options:

7− "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists

7+ "$locals": |

8+ -Weverything

9+ -Wno-unsafe

10+ -Wno-safe

11+ -Wno-missing-safe-haskell-mode

12+ -Wno-missing-import-lists

13+ -Wno-missing-kind-signatures

14+ -Wno-all-missed-specialisations

15+ -Wno-missed-specialisations

16+ -Wno-partial-type-signatures

17+ -Wno-partial-fields

18+ -Wno-operator-whitespace

19+ -Wno-missed-extra-shared-lib

20+ -Wno-missing-role-annotations

21+ -Wno-missing-poly-kind-signatures

22+ -Wno-implicit-prelude

23+ -threaded

task.cabal+14−4

@@ -1,10 +1,10 @@

11cabal-version: 2.2

3−-- This file has been generated from package.yaml by hpack version 0.33.0.

3+-- This file has been generated from package.yaml by hpack version 0.37.0.

44--

55-- see: https://github.com/sol/hpack

66--

7−-- hash: c454617de75af64ca6c743a3a745918472bb438f8df9c2019b67700d4caaf63c

7+-- hash: d4671383815d2a08c8473740521f11d0ebd39c19bfc0be7f68aa522e17a866ee

99name: task

1010version: 0.1.0.0

@@ -17,10 +17,14 @@ library

1717 Task

1818 other-modules:

1919 Paths_task

20+ autogen-modules:

21+ Paths_task

2022 hs-source-dirs:

2123 src

24+ default-extensions:

25+ DerivingStrategies

2226 build-depends:

23− base >=4.7 && <5

27+ base

2428 default-language: Haskell2010

2529

2630test-suite task-tests

@@ -29,10 +33,16 @@ test-suite task-tests

2933 other-modules:

3034 Tests

3135 Paths_task

36+ autogen-modules:

37+ Paths_task

3238 hs-source-dirs:

3339 test

40+ default-extensions:

41+ DerivingStrategies

3442 build-depends:

35− base >=4.7 && <5

43+ QuickCheck

44+ , base

45+ , hspec

3646 , task

3747 , tasty

3848 , tasty-hspec

test/Tests.hs+354−3

@@ -1,11 +1,362 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE TypeApplications #-}

4+{-# OPTIONS_GHC -O0 #-}

5+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

6+{-# OPTIONS_GHC -Wno-orphans #-}

7+{-# OPTIONS_GHC -fno-enable-rewrite-rules #-}

19module Tests

210 ( tests,

311 )

412where

513

14+import Control.Arrow

15+import Data.List (sort)

16+import Data.Maybe

617import Task

7−import Test.Tasty.Hspec

18+import Test.QuickCheck

19+import Test.Hspec

820

921tests :: Spec

10−tests = do

11− return ()

22+tests = parallel $ do

23+ describe "ErrorState" $ do

24+ let eqState ::

25+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>

26+ ErrorState e s a ->

27+ ErrorState e s a ->

28+ Property

29+ eqState lhs rhs = property $ \s -> runErrorState lhs s === runErrorState rhs s

30+ describe "Functor" $ do

31+ specify "fmap id = id" $ do

32+ let testProperty ::

33+ forall e s a.

34+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>

35+ Blind (ErrorState e s a) ->

36+ Property

37+ testProperty (Blind s) = fmap id s `eqState` s

38+ conjoin

39+ [ property $ testProperty @() @Bool @Char,

40+ property $ testProperty @Int @Char @Bool,

41+ property $ testProperty @[Int] @[Bool] @Char,

42+ property $ testProperty @String @Bool @String

43+ ]

44+ specify "fmap (g . f) = fmap g . fmap f" $ do

45+ let testProperty ::

46+ forall e s a b c.

47+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq c, Show c) =>

48+ Blind (ErrorState e s a) ->

49+ Fun a b ->

50+ Fun b c ->

51+ Property

52+ testProperty (Blind s) f' g' = fmap (g . f) s `eqState` (fmap g . fmap f) s

53+ where

54+ f = applyFun f'

55+ g = applyFun g'

56+ conjoin

57+ [ property $ testProperty @() @Bool @Char @Int @Char,

58+ property $ testProperty @Int @Char @Bool @() @Char,

59+ property $ testProperty @[Int] @[Bool] @Char @Int @Bool,

60+ property $ testProperty @String @Bool @String @Bool @Char

61+ ]

62+ describe "Applicative" $ do

63+ specify "pure id <*> v = v" $ do

64+ let testProperty ::

65+ forall e s a.

66+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>

67+ Blind (ErrorState e s a) ->

68+ Property

69+ testProperty (Blind s) = (pure id <*> s) `eqState` s

70+ conjoin

71+ [ property $ testProperty @() @Bool @Char,

72+ property $ testProperty @Int @Char @Bool,

73+ property $ testProperty @[Int] @[Bool] @Char,

74+ property $ testProperty @String @Bool @String

75+ ]

76+ specify "pure f <*> pure x = pure (f x)" $ do

77+ let testProperty ::

78+ forall e s a b.

79+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq b, Show b) =>

80+ a ->

81+ Fun a b ->

82+ Property

83+ testProperty x f' = (pure f <*> pure x) `eqState` (pure (f x) :: ErrorState e s b)

84+ where

85+ f = applyFun f'

86+ conjoin

87+ [ property $ testProperty @() @Bool @Char @Int,

88+ property $ testProperty @Int @Char @Bool @(),

89+ property $ testProperty @[Int] @[Bool] @Char @Bool,

90+ property $ testProperty @String @Bool @String @Char

91+ ]

92+ describe "Monad" $ do

93+ specify "m >>= return = m" $ do

94+ let testProperty ::

95+ forall e s a.

96+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>

97+ Blind (ErrorState e s a) ->

98+ Property

99+ testProperty (Blind s) = (s >>= return) `eqState` s

100+ conjoin

101+ [ property $ testProperty @() @Bool @Char,

102+ property $ testProperty @Int @Char @Bool,

103+ property $ testProperty @[Int] @[Bool] @Char,

104+ property $ testProperty @String @Bool @String

105+ ]

106+ specify "return a >>= f = f a" $ do

107+ let testProperty ::

108+ forall e s a b.

109+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq b, Show b) =>

110+ a ->

111+ Blind (Fun a (ErrorState e s b)) ->

112+ Property

113+ testProperty x (Blind f') = (return x >>= f) `eqState` f x

114+ where

115+ f = applyFun f'

116+ conjoin

117+ [ property $ testProperty @() @Bool @Char @Int,

118+ property $ testProperty @Int @Char @Bool @(),

119+ property $ testProperty @[Int] @[Bool] @Char @Bool,

120+ property $ testProperty @String @Bool @String @Char

121+ ]

122+ specify "m >>= (\\x -> f x >>= g) = (m >>= f) >>= g" $ do

123+ let testProperty ::

124+ forall e s a b c.

125+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq c, Show c) =>

126+ Blind (ErrorState e s a) ->

127+ Blind (Fun a (ErrorState e s b)) ->

128+ Blind (Fun b (ErrorState e s c)) ->

129+ Property

130+ testProperty (Blind m) (Blind f') (Blind g') = (m >>= (\x -> f x >>= g)) `eqState` ((m >>= f) >>= g)

131+ where

132+ f = applyFun f'

133+ g = applyFun g'

134+ conjoin

135+ [ property $ testProperty @() @Bool @Char @Int @Char,

136+ property $ testProperty @Int @Char @Bool @() @Char,

137+ property $ testProperty @[Int] @[Bool] @Char @Int @Bool,

138+ property $ testProperty @String @Bool @String @Bool @Char

139+ ]

140+ specify "get" $ do

141+ let testGet :: forall b. (Show b, Eq b) => b -> Property

142+ testGet s = executeErrorState s get === (Right s :: Either () b)

143+ conjoin

144+ [ property $ testGet @(),

145+ property $ testGet @Int,

146+ property $ testGet @[Int],

147+ property $ testGet @String

148+ ]

149+ specify "put" $ do

150+ let testPut :: forall b. (Show b, Eq b) => b -> b -> Property

151+ testPut s s' = runErrorState (put s') s === (Right ((), s') :: Either () ((), b))

152+ conjoin

153+ [ property $ testPut @(),

154+ property $ testPut @Int,

155+ property $ testPut @[Int],

156+ property $ testPut @String

157+ ]

158+ specify "throwError" $ do

159+ let testThrowError :: forall e. (Show e, Eq e) => e -> Property

160+ testThrowError e = runErrorState (throwError e) undefined === (Left e :: Either e ((), ()))

161+ conjoin

162+ [ property $ testThrowError @(),

163+ property $ testThrowError @Int,

164+ property $ testThrowError @[Int],

165+ property $ testThrowError @String

166+ ]

167+ specify "modify" $ do

168+ let testModify :: forall b. (Show b, Eq b) => Fun b b -> b -> Property

169+ testModify f b = runErrorState (modify $ applyFun f) b === (Right ((), applyFun f b) :: Either () ((), b))

170+ conjoin

171+ [ property $ testModify @(),

172+ property $ testModify @Int,

173+ property $ testModify @[Int],

174+ property $ testModify @String

175+ ]

176+ describe "BFMonad" $ do

177+ describe "readInput" $ do

178+ let state i =

179+ BFState

180+ { bfDataTape = undefined,

181+ bfInput = i,

182+ bfOutput = undefined

183+ }

184+ specify "non-empty" $ do

185+ let testReadInput :: NonEmptyList Int -> Property

186+ testReadInput (NonEmpty l@(x : xs)) =

187+ ((fst &&& bfInput . snd) <$> runErrorState readInput (state l)) === Right (x, xs)

188+ property testReadInput

189+ specify "empty" $ do

190+ executeErrorState (state []) readInput

191+ `shouldBe` Left NotEnoughInput

192+ specify "writeOutput" $ do

193+ let state =

194+ BFState

195+ { bfDataTape = undefined,

196+ bfInput = undefined,

197+ bfOutput = []

198+ }

199+ testWriteOutput :: [Int] -> Property

200+ testWriteOutput l =

201+ (bfOutput . snd <$> runErrorState (mapM_ writeOutput l) state) === Right (reverse l)

202+ property testWriteOutput

203+ specify "shiftDataR" $ do

204+ let state t =

205+ BFState

206+ { bfDataTape = t,

207+ bfInput = undefined,

208+ bfOutput = undefined

209+ }

210+ testShiftDataR :: Tape Int -> Property

211+ testShiftDataR t = case shiftTapeR t of

212+ Nothing -> runErrorState shiftDataR (state t) === Left DataTapeExhausted

213+ Just t' -> (bfDataTape . snd <$> runErrorState shiftDataR (state t)) === Right t'

214+ property testShiftDataR

215+ specify "shiftDataL" $ do

216+ let state t =

217+ BFState

218+ { bfDataTape = t,

219+ bfInput = undefined,

220+ bfOutput = undefined

221+ }

222+ testShiftDataL :: Tape Int -> Property

223+ testShiftDataL t = case shiftTapeL t of

224+ Nothing -> runErrorState shiftDataL (state t) === Left DataTapeExhausted

225+ Just t' -> (bfDataTape . snd <$> runErrorState shiftDataL (state t)) === Right t'

226+ property testShiftDataL

227+ specify "readData" $ do

228+ let state t =

229+ BFState

230+ { bfDataTape = t,

231+ bfInput = undefined,

232+ bfOutput = undefined

233+ }

234+ testReadData :: Tape Int -> Property

235+ testReadData t =

236+ executeErrorState (state t) readData === Right (tapeValue t)

237+ property testReadData

238+ specify "writeData" $ do

239+ let state t =

240+ BFState

241+ { bfDataTape = t,

242+ bfInput = undefined,

243+ bfOutput = undefined

244+ }

245+ testWriteData :: Tape Int -> Int -> Property

246+ testWriteData t x =

247+ (bfDataTape . snd <$> runErrorState (writeData x) (state t)) === Right t {tapeValue = x}

248+ property testWriteData

249+ describe "BF" $ do

250+ describe "executeCommand" $ do

251+ specify "ShiftRight" $ do

252+ let state t =

253+ BFState

254+ { bfDataTape = t,

255+ bfInput = undefined,

256+ bfOutput = undefined

257+ }

258+ testShiftRight :: Tape Int -> Property

259+ testShiftRight t = case shiftTapeR t of

260+ Nothing -> runErrorState (executeCommand ShiftRight) (state t) === Left DataTapeExhausted

261+ Just t' -> (bfDataTape . snd <$> runErrorState (executeCommand ShiftRight) (state t)) === Right (t')

262+ property testShiftRight

263+ specify "ShiftLeft" $ do

264+ let state t =

265+ BFState

266+ { bfDataTape = t,

267+ bfInput = undefined,

268+ bfOutput = undefined

269+ }

270+ testShiftLeft :: Tape Int -> Property

271+ testShiftLeft t = case shiftTapeL t of

272+ Nothing -> runErrorState (executeCommand ShiftLeft) (state t) === Left DataTapeExhausted

273+ Just t' -> (bfDataTape . snd <$> runErrorState (executeCommand ShiftLeft) (state t)) === Right (t')

274+ property testShiftLeft

275+ specify "Increment" $ do

276+ let state t =

277+ BFState

278+ { bfDataTape = t,

279+ bfInput = undefined,

280+ bfOutput = undefined

281+ }

282+ testProperty :: Tape Int -> Property

283+ testProperty t =

284+ (bfDataTape . snd <$> runErrorState (executeCommand Increment) (state t)) === Right (touchTape (+ 1) t)

285+ property testProperty

286+ specify "Decrement" $ do

287+ let state t =

288+ BFState

289+ { bfDataTape = t,

290+ bfInput = undefined,

291+ bfOutput = undefined

292+ }

293+ testProperty :: Tape Int -> Property

294+ testProperty t =

295+ (bfDataTape . snd <$> runErrorState (executeCommand Decrement) (state t)) === Right (touchTape pred t)

296+ property testProperty

297+ specify "WriteOutput" $ do

298+ let state t o =

299+ BFState

300+ { bfDataTape = t,

301+ bfInput = undefined,

302+ bfOutput = o

303+ }

304+ testProperty :: Tape Int -> [Int] -> Property

305+ testProperty t l =

306+ ((bfDataTape &&& bfOutput) . snd <$> runErrorState (executeCommand WriteOutput) (state t l))

307+ === Right (t, tapeValue t : l)

308+ property testProperty

309+ specify "ReadInput" $ do

310+ let state t i =

311+ BFState

312+ { bfDataTape = t,

313+ bfInput = i,

314+ bfOutput = undefined

315+ }

316+ testProperty :: Tape Int -> [Int] -> Property

317+ testProperty t l = case l of

318+ [] -> runErrorState (executeCommand ReadInput) (state t l) === Left NotEnoughInput

319+ (x : xx) -> ((bfDataTape &&& bfInput) . snd <$> runErrorState (executeCommand ReadInput) (state t l)) === Right ((t {tapeValue = x}, xx))

320+ property testProperty

321+ specify "Loop" $ do

322+ let toList :: Tape a -> [a]

323+ toList t = reverse (leftTape t) <> [tapeValue t] <> rightTape t

324+ testLoop i o l =

325+ (toList . bfDataTape . snd <$> runErrorState (executeCommand (Loop l)) (state . fromJust . initializeTape $ i))

326+ `shouldBe` Right o

327+ state t =

328+ BFState

329+ { bfDataTape = t,

330+ bfInput = undefined,

331+ bfOutput = undefined

332+ }

333+ testLoop [0] [0] []

334+ testLoop [0] [0] [Loop []]

335+ testLoop [5] [0] [Loop [Decrement]]

336+ testLoop [5, 5, 1, 2, 0] [6, 6, 2, 3, 0] [Increment, ShiftRight]

337+ describe "executeProgram" $ do

338+ specify "Hello World" $ do

339+ executeProgram "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++." "" `shouldBe` Just "Hello World!\n"

340+ specify "Bubble Sort" $ do

341+ let sort' x = executeProgram ">>>>>,[>>>,]<<<[<<<[>>>[-<<<-<+>[>]>>]<<<[<]>>[>>>+<<<-]<[>+>>>+<<<<-]<<]>>>[.[-]]>>>[>>>]<<<]" (x <> "\NUL")

342+ property . withMaxSuccess 10 $ \(l :: String) -> let l' = filter (/= '\NUL') l in sort' l' === Just (sort l')

343+ specify "wc" $ do

344+ let wc x = executeProgram ">>>+>>>>>+>>+>>+[<<],[-[-[-[-[-[-[-[-[<+>-[>+<-[>-<-[-[-[<++[<++++++>-]<[>>[-<]<[>]<-]>>[<+>-[<->[-]]]]]]]]]]]]]]]]<[-<<[-]+>]<<[>>>>>>+<<<<<<-]>[>]>>>>>>>+>[<+[>+++++++++<-[>-<-]++>[<+++++++>-[<->-]+[+>>>>>>]]<[>+<-]>[>>>>>++>[-]]+<]>[-<<<<<<]>>>>],]+<++>>>[[+++++>>>>>>]<+>+[[<++++++++>-]<.<<<<<]>>>>>>>>]" (x <> "\NUL")

345+ wc "Hello.\nThis is a thing.\nYay!" `shouldBe` Just "\t2\t6\t28\n"

346+ wc "Hello.\n This is text\nThis is a thing.\nYay!" `shouldBe` Just "\t3\t9\t42\n"

347+ wc "Hello.\n This is \n djnjd \n text\nThis is a thing.\nYay!" `shouldBe` Just "\t5\t10\t52\n"

348+ specify "Squares" $ do

349+ executeProgram "++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]" ""

350+ `shouldBe` Just (unlines . fmap (show @Int) . takeWhile (<= 10000) . fmap (\x -> x * x) $ [0 ..])

351+ specify "Insertion Sort" $ do

352+ let sort' x = executeProgram ">>+>,[<[[>>+<<-]>[<<+<[->>+[<]]>>>[>]<<-]<<<]>>[<<+>>-]<[>+<-]>[>>]<,]<<<[<+<]>[>.>]" (x <> "\NUL")

353+ property . withMaxSuccess 10 $ \(l :: String) -> let l' = filter (/= '\NUL') l in sort' l' === Just (sort l')

354+

355+instance Arbitrary a => Arbitrary (Tape a) where

356+ arbitrary = applyArbitrary3 Tape

357+

358+instance

359+ (Arbitrary e, Arbitrary a, Function s, CoArbitrary s, Arbitrary s) =>

360+ Arbitrary (ErrorState e s a)

361+ where

362+ arbitrary = ErrorState . applyFun <$> arbitrary