diff --git a/bf-optimize.cabal b/bf-optimize.cabal index cd815da..ca802e7 100644 --- a/bf-optimize.cabal +++ b/bf-optimize.cabal @@ -29,6 +29,7 @@ library Language.Brainfuck.Instruction Language.Brainfuck.Instruction.Compressed Language.Brainfuck.Instruction.Extended + Language.Brainfuck.Interpreter other-modules: Paths_bf_optimize autogen-modules: @@ -37,7 +38,9 @@ library src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 + , quickcheck-instances , text , vector default-language: Haskell2010 @@ -52,8 +55,10 @@ executable bf-optimize-exe app ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , bf-optimize + , quickcheck-instances , text , vector default-language: Haskell2010 @@ -62,6 +67,8 @@ test-suite bf-optimize-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Arbitrary.InvalidBrainfuckText + Arbitrary.ValidBrainfuckText Paths_bf_optimize autogen-modules: Paths_bf_optimize @@ -69,8 +76,10 @@ test-suite bf-optimize-test test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , bf-optimize + , quickcheck-instances , text , vector default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 8aebee4..3b9462d 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,8 @@ dependencies: - base >= 4.7 && < 5 - text - vector +- QuickCheck +- quickcheck-instances ghc-options: - -Wall diff --git a/src/Language/Brainfuck.hs b/src/Language/Brainfuck.hs index 0d0e320..c348315 100644 --- a/src/Language/Brainfuck.hs +++ b/src/Language/Brainfuck.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingStrategies #-} -module Language.Brainfuck (parse, ParseFailure) where +{-# LANGUAGE LambdaCase #-} +module Language.Brainfuck (parse, ParseFailure, render) where import Control.Monad ((<$!>)) import Control.Monad.ST (runST, ST) @@ -14,11 +15,12 @@ import Data.Vector qualified as Vector import Data.Vector.Mutable qualified as MutableVector import Language.Brainfuck.Instruction ( Instruction(..) ) +import qualified Data.List as List data ParseFailure = UnexpectedClosingBracket Int -- closing bracket position | UnmatchedOpenBracket Int -- opening bracket position - deriving stock (Show) + deriving stock (Show, Eq) -- | Convert a Text to a list of instructions, discard all comments. -- @@ -83,3 +85,21 @@ parse text = runST $ do -- >>> parse $ Text.pack "[]]" -- Left (UnexpectedClosingBracket 2) + +render :: Vector Instruction -> Text +render = Text.concat . List.map renderSingle . Vector.toList + where + renderSingle = \case + Increment -> Text.singleton '+' + Decrement -> Text.singleton '-' + MoveLeft -> Text.singleton '<' + MoveRight -> Text.singleton '>' + ReadByte -> Text.singleton ',' + PutByte -> Text.singleton '.' + Loop body -> Text.concat [Text.singleton '[', render body, Text.singleton ']'] + +-- >>> import Test.QuickCheck.Instances.Vector () +-- >>> import Test.QuickCheck.Arbitrary (arbitrary) +-- >>> render <$> Gen.generate arbitrary +-- "<,<>,<,." + diff --git a/src/Language/Brainfuck/Instruction.hs b/src/Language/Brainfuck/Instruction.hs index a1a6a70..80a52aa 100644 --- a/src/Language/Brainfuck/Instruction.hs +++ b/src/Language/Brainfuck/Instruction.hs @@ -1,7 +1,13 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE InstanceSigs #-} module Language.Brainfuck.Instruction (Instruction(..)) where import Data.Vector ( Vector ) +import Test.QuickCheck.Gen (Gen) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) +import Test.QuickCheck.Instances.Vector () + +import qualified Test.QuickCheck.Gen as Gen data Instruction = Increment @@ -12,3 +18,20 @@ data Instruction | PutByte | Loop (Vector Instruction) deriving stock (Show, Eq) + +instance Arbitrary Instruction where + arbitrary :: Gen Instruction + arbitrary = Gen.oneof $ + [ pure Increment + , pure Decrement + , pure MoveLeft + , pure MoveRight + , pure ReadByte + , pure PutByte + , Loop <$> reduceSize 8 arbitrary + ] + where + reduceSize d g = Gen.sized $ \ s -> Gen.resize (s `div` d) g + +-- >>> Gen.generate (Gen.resize 30 arbitrary) :: IO [Instruction] +-- [MoveLeft,Decrement,PutByte,Decrement,Decrement,Increment,ReadByte,MoveLeft,Increment,Loop [],MoveRight,Increment,Increment,Loop [],MoveLeft,Loop [],MoveRight,ReadByte,ReadByte,MoveLeft,Decrement,MoveRight,MoveLeft,Loop [PutByte,Increment,Loop []],Decrement] diff --git a/src/Language/Brainfuck/Instruction/Compressed.hs b/src/Language/Brainfuck/Instruction/Compressed.hs index c57224f..bf28a1d 100644 --- a/src/Language/Brainfuck/Instruction/Compressed.hs +++ b/src/Language/Brainfuck/Instruction/Compressed.hs @@ -1,13 +1,19 @@ {-# LANGUAGE ImportQualifiedPost #-} -module Language.Brainfuck.Instruction.Compressed ( CompressedInstruction(..), compress ) where +{-# LANGUAGE InstanceSigs #-} +module Language.Brainfuck.Instruction.Compressed ( CompressedInstruction(..), compress, uncompress ) where import Data.Bifunctor ( Bifunctor(first) ) import Data.Vector ( Vector ) import Data.Word ( Word8 ) import Numeric.Natural ( Natural ) +import Test.QuickCheck.Gen (Gen) +import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary)) +import Test.QuickCheck.Instances.Natural () import Data.Vector qualified as Vector +import Test.QuickCheck.Gen qualified as Gen + import Language.Brainfuck.Instruction ( Instruction ) import Language.Brainfuck.Instruction qualified as Instruction @@ -21,6 +27,20 @@ data CompressedInstruction | Loop (Vector CompressedInstruction) deriving (Show, Eq) +instance Arbitrary CompressedInstruction where + arbitrary :: Gen CompressedInstruction + arbitrary = Gen.oneof + [ Add <$> arbitrary + , Subtract <$> arbitrary + , MoveRight <$> arbitrary + , MoveLeft <$> arbitrary + , pure ReadByte + , pure PutByte + , Loop <$> resize (`div` 8) arbitrary + ] + where + resize f x = Gen.sized $ \ s -> Gen.resize (f s) x + compress :: Vector Instruction -> Vector CompressedInstruction compress instructions = Vector.fromList (go instructions) where @@ -51,3 +71,18 @@ compress instructions = Vector.fromList (go instructions) -- >>> compress . Vector.fromList $ replicate 300 Instruction.MoveRight -- [MoveRight 300] +uncompress :: Vector CompressedInstruction -> Vector Instruction +uncompress = Vector.concatMap uncompressSingle + where + uncompressSingle instruction = let + repeated x times = Vector.replicate (fromIntegral times) x + + in case instruction of + Add times -> repeated Instruction.Increment times + Subtract times -> repeated Instruction.Decrement times + MoveRight times -> repeated Instruction.MoveRight times + MoveLeft times -> repeated Instruction.MoveLeft times + PutByte -> Vector.singleton Instruction.PutByte + ReadByte -> Vector.singleton Instruction.ReadByte + Loop body -> Vector.singleton $ Instruction.Loop (uncompress body) + diff --git a/src/Language/Brainfuck/Instruction/Extended.hs b/src/Language/Brainfuck/Instruction/Extended.hs index e3b8d9d..5fb434c 100644 --- a/src/Language/Brainfuck/Instruction/Extended.hs +++ b/src/Language/Brainfuck/Instruction/Extended.hs @@ -1,12 +1,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StrictData #-} module Language.Brainfuck.Instruction.Extended (Operation(..), Interaction(..), ExtendedInstruction(Modify, Move, Interact, Jump), pattern IfNonZero, pattern WithOffset, mkIfNonZero, mkWithOffset, translationSize, parse) where + import Data.Word (Word8) -import Language.Brainfuck.Instruction.Compressed (CompressedInstruction) import Data.Vector (Vector) +import Numeric.Natural (Natural) + +import Language.Brainfuck.Instruction.Compressed (CompressedInstruction) + import qualified Data.Vector as Vector import qualified Language.Brainfuck.Instruction.Compressed as CompressedInstruction -import Numeric.Natural (Natural) data Operation = Add @@ -18,7 +22,7 @@ data Interaction | Write deriving (Show) -pattern WithOffset :: Int -> ExtendedInstruction -> ExtendedInstruction +pattern WithOffset :: Integer -> ExtendedInstruction -> ExtendedInstruction pattern WithOffset offset embedded <- AtOffset offset embedded where WithOffset offset embedded = mkWithOffset offset embedded @@ -29,7 +33,7 @@ pattern IfNonZero instruction <- WhenNonZero instruction IfNonZero instruction = mkIfNonZero instruction data ExtendedInstruction - = AtOffset Int ExtendedInstruction -- invariant, WithOffset may not nest itself + = AtOffset Integer ExtendedInstruction -- invariant, WithOffset may not nest itself | WhenNonZero ExtendedInstruction -- invariant, IfNonZero may not nest itself | Modify Operation Word8 | Move Integer @@ -42,7 +46,7 @@ mkIfNonZero = \case WhenNonZero i -> WhenNonZero i instruction -> WhenNonZero instruction -mkWithOffset :: Int -> ExtendedInstruction -> ExtendedInstruction +mkWithOffset :: Integer -> ExtendedInstruction -> ExtendedInstruction mkWithOffset offset = \case AtOffset offset' i -> AtOffset (offset + offset') i instruction -> AtOffset offset instruction @@ -92,4 +96,3 @@ translationSize = Vector.sum . Vector.map instructionTranslationSize -- -- >>> parse [CompressedInstruction.Add 5, CompressedInstruction.Loop [CompressedInstruction.Loop [CompressedInstruction.ReadByte], CompressedInstruction.PutByte]] -- [Modify Add 5,Jump 4,Jump 1,Interact Read,WhenNonZero (Jump (-2)),Interact Write,WhenNonZero (Jump (-5))] - diff --git a/test/Arbitrary/InvalidBrainfuckText.hs b/test/Arbitrary/InvalidBrainfuckText.hs new file mode 100644 index 0000000..42b97f1 --- /dev/null +++ b/test/Arbitrary/InvalidBrainfuckText.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} +module Arbitrary.InvalidBrainfuckText (InvalidBrainfuckText(..)) where + +import Data.Text (Text) +import Test.QuickCheck.Gen (Gen) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) + +import qualified Data.Text as Text +import qualified Test.QuickCheck.Gen as Gen +import qualified Arbitrary.ValidBrainfuckText as ValidBrainfuckText + +newtype InvalidBrainfuckText = InvalidBrainfuckText { get :: Text } + deriving stock Show + +instance Arbitrary InvalidBrainfuckText where + arbitrary :: Gen InvalidBrainfuckText + arbitrary = do + validText <- ValidBrainfuckText.get <$> arbitrary + + index <- Gen.choose (0, Text.length validText) + badBrace <- Gen.oneof $ map pure "[]" + let (prefix, suffix) = Text.splitAt index validText + + pure . InvalidBrainfuckText $ Text.concat [prefix, Text.singleton badBrace, suffix] + diff --git a/test/Arbitrary/ValidBrainfuckText.hs b/test/Arbitrary/ValidBrainfuckText.hs new file mode 100644 index 0000000..c5a0505 --- /dev/null +++ b/test/Arbitrary/ValidBrainfuckText.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} +module Arbitrary.ValidBrainfuckText (ValidBrainfuckText(..)) where +import Data.Text (Text) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) +import Test.QuickCheck.Gen (Gen, sized, frequency, oneof, resize) +import Data.Coerce (coerce) + +import qualified Data.Text as Text + +newtype ValidBrainfuckText = ValidBrainfuckText { get :: Text } + deriving stock Show + +instance Arbitrary ValidBrainfuckText where + arbitrary :: Gen ValidBrainfuckText + arbitrary = coerce . fmap Text.pack $ character [] + where + character rest = do + body <- frequency + [ (1, comment) + , (9, operator) + ] + + sized $ \ size -> frequency + [ (1 , pure body) + , (size, character body) + ] + + where + operator = let + + simpleOperator = oneof $ map (pure . (:rest)) "+-<>,." + loopOperator = fmap ('[':) . sized $ \ s -> resize (s `div` 8) (character (']':rest)) + + in frequency + [ (3, simpleOperator) + , (1, loopOperator) + ] + + comment = do + commentChar <- oneof $ map pure "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + pure $ commentChar : rest + +-- >>> import Test.QuickCheck.Gen (generate) +-- >>> generate $ (arbitrary :: Gen ValidBrainfuckText) +-- ValidBrainfuckText {get = "<[><]>[>],>+,[.-K.]+.>[<],z[p[[<]]+<],<[+]+[P[+][[e]]+,]+,.[-][[<],>>++]+"} + + diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..449530c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.Vector (Vector) + +import Test.QuickCheck.All (quickCheckAll) +import System.Exit (exitFailure, exitSuccess) + +import Language.Brainfuck.Instruction (Instruction) + +import qualified Data.Either as Either +import qualified Language.Brainfuck as Brainfuck +import qualified Arbitrary.ValidBrainfuckText as ValidBrainfuckText +import qualified Arbitrary.InvalidBrainfuckText as InValidBrainfuckText +import qualified Language.Brainfuck.Instruction.Compressed as CompressedInstruction + +-- | ValidBrainfuckText will produce a text with comments, it must be parsed correctly +prop_acceptValidTexts :: ValidBrainfuckText.ValidBrainfuckText -> Bool +prop_acceptValidTexts = Either.isRight . Brainfuck.parse . ValidBrainfuckText.get + +-- | InvalidBrainfuckText will insert unbalanced brackets, they must be rejected +prop_rejectInvalidTexts :: InValidBrainfuckText.InvalidBrainfuckText -> Bool +prop_rejectInvalidTexts = Either.isLeft . Brainfuck.parse . InValidBrainfuckText.get + +-- | Does rendering and parsing a vector of instructions yield the exact same result? +prop_renderParseInverse :: Vector Instruction -> Bool +prop_renderParseInverse source = Right source == (Brainfuck.parse . Brainfuck.render $ source) + +-- | Compressing and Uncompressing should be inverse. The opposite must not be true, since `compress $ replicate 300 Increment` is `Add 44` +prop_CompressUncompressInverse :: Vector Instruction -> Bool +prop_CompressUncompressInverse source = source == (CompressedInstruction.uncompress . CompressedInstruction.compress) source + +return [] -- template haskell guard +runQuickCheck :: IO Bool +runQuickCheck = $quickCheckAll + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + quickCheckGood <- runQuickCheck + + if quickCheckGood then exitSuccess else exitFailure