never executed always true always false
1 {-# LANGUAGE DeriveAnyClass #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE DerivingStrategies #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 {-# LANGUAGE InstanceSigs #-}
7 {-# LANGUAGE RecordWildCards #-}
8
9 {-|
10 Description : Basic types for the Brainfuck compiler and virtual machine.
11 Copyright : (c) Sebastian Galkin, 2018
12 License : GPL-3
13
14 All the basic types for the Brainfuck compiler and VM are defined in this module.
15 This includes the different instructions ('Op's), the 'Program' and the 'MachineIO'.
16 -}
17 module HBF.Types where
18
19 import Control.DeepSeq (NFData)
20 import Control.Exception (catch)
21 import Control.Monad.Trans.State.Strict (StateT, get, modify, put)
22 import Data.Binary (Binary)
23 import Data.Char (chr, ord)
24 import Data.Int (Int8)
25 import Data.List (uncons)
26 import Data.Semigroup (Semigroup (..))
27 import GHC.Generics (Generic)
28 import System.IO (hFlush, stdout)
29
30 -- * Virtual Machine Instructions
31 -- | Operations or instructions in the Brainfuck virtual machine.
32 --
33 -- Some of these operations are \"native\" to Brainfuck and others are the result of optimization during compilation.
34 -- The compiler generates these types of instructions and the virtual machine can execute them.
35 --
36 -- In all these instructions the 'MemOffset' represents a shift relative to the current position of the pointer.
37 -- The operation will refer and apply its action to this shifted position.
38 data Op
39 -- | Increment by the amount specified by the @Int@
40 = Inc {-# UNPACK #-}!Int
41 {-# UNPACK #-}!MemOffset
42 -- | Move the current pointer by the specified amount
43 | Move {-# UNPACK #-}!MemOffset
44 -- | Repeatedly read a byte into the machine and write the last one read to the shifted position.
45 -- @n@ is usually 1 in real programs, but not always. Where the byte is read from will depend on the 'MachineIO' impleentation.
46 | In {-# UNPACK #-}!Int
47 {-# UNPACK #-}!MemOffset
48 -- | Repeatedly write the byte in the shifted position. Where the byte is written will depend on the 'MachineIO' impleentation.
49 | Out {-# UNPACK #-}!Int
50 {-# UNPACK #-}!MemOffset
51 -- | Native Brainfuck looping instruction.
52 | Loop ![Op]
53 -- | Optimized instruction. Set the shifted position to zero. In Brainfuck this is usually written as @[-]@
54 | Clear {-# UNPACK #-}!MemOffset
55 -- | Optimized instruction. Multiply by the factor the byte in the first @MemOffset@, writting to the second one.
56 -- Second @MemOffset@ is relative to the first one. In brainfuck this is usually written as [->+<] and similar
57 -- expressions.
58 | Mul {-# UNPACK #-}!MulFactor
59 {-# UNPACK #-}!MemOffset
60 {-# UNPACK #-}!MemOffset
61 -- | Find the nearest zero in the given direction, starting at the offset position. See 'Direction'.
62 | Scan !Direction
63 {-# UNPACK #-}!MemOffset
64 deriving (Show, Eq, Generic, Binary, NFData)
65
66 -- | An offset into the Brainfuck VM memory. Positive numbers are in the direction of higher memory.
67 newtype MemOffset =
68 MemOffset Int
69 deriving (Generic)
70 deriving newtype (Show, Eq, Num, Ord)
71 deriving anyclass (Binary, NFData)
72
73 -- | A factor to multiply by in the 'Mul' instruction.
74 newtype MulFactor =
75 MulFactor Int
76 deriving (Generic)
77 deriving newtype (Show, Eq, Num)
78 deriving anyclass (Binary, NFData)
79
80 -- | A direction to 'Scan' for a memory position. 'Up' is in the direction of higher memory.
81 data Direction
82 = Up -- ^ Scan in the direction of higher memory.
83 | Down -- ^ Scan in the direction of lower memory.
84 deriving (Show, Eq, Generic)
85 deriving anyclass (Binary, NFData)
86
87 -- * Programs
88 -- | Marker type to distinguish optimized and 'Unoptimized' 'Program's.
89 data Optimized
90
91 -- | Marker type to distinguish 'Optimized' and unoptimized 'Program's.
92 data Unoptimized
93
94 -- | A list of 'Op's. 'opt' will be one of 'Optimized' or 'Unoptimized' to
95 -- distinguish both types of programs at the type level.
96 newtype Program opt = Program
97 { instructions :: [Op] -- ^ The list of instructions in the program.
98 } deriving (Generic) deriving newtype (Show, Eq) deriving anyclass ( Binary
99 , NFData
100 )
101
102 -- | Return the full list of instructions in a program, by unrolling 'Loop' instructions
103 -- into the list.
104 --
105 -- >>> flattened $ Program [Inc 1 0, Loop [Move 1, Scan Up 0]]
106 -- [Inc 1 0,Move 1,Scan Up 0]
107 flattened :: Program o -> [Op]
108 flattened p = [atom | op <- instructions p, atom <- atoms op]
109 where
110 atoms (Loop ops) = concatMap atoms ops
111 atoms other = [other]
112
113 -- | Apply '<>' to the underlying @List@ of instructions.
114 instance Semigroup (Program o) where
115 Program a <> Program b = Program $ a <> b
116
117 -- | The 'Monoid' of the underlying @List@ of instructions.
118 instance Monoid (Program o) where
119 mappend = (<>)
120 mempty = Program mempty
121
122 -- * Runtime State
123 -- | The state of a Brainfuck virtual machine.
124 data Machine v = Machine
125 { memory :: v -- ^ The full memory of the machine. This will be a 'Data.Vector.Unboxed.Vector' or a List.
126 , pointer :: MemOffset -- ^ The current execution pointer, information is written and read at this position.
127 } deriving (Show, Eq)
128
129 -- * VM Input/Output
130 -- | Provide input and output to a Brainfuck virtual machine.
131 --
132 -- This class allows to run the VM in different monads, like 'IO' or 'StateT'.
133 class MachineIO m where
134 putByte :: Int8 -> m () -- ^ Write the byte to the output of the VM.
135 getByte :: m (Maybe Int8) -- ^ Read a byte from the input of the VM. If @EOF@ has been reached, return 'Nothing'
136
137 -- | 'IO' takes its input and output from stdin/stdout
138 instance MachineIO IO where
139 putByte = putChar . toEnum . fromIntegral
140 getByte = fmap (fromIntegral . fromEnum) <$> (hFlush stdout >> safeGetChar)
141 where
142 safeGetChar = fmap Just getChar `catch` recover
143 recover :: IOError -> IO (Maybe Char)
144 recover _ = return Nothing
145
146 -- * Test Helpers
147 -- | A data structure for mocking input and output to the VM. This can be used to run the VM
148 -- in a 'StateT' monad for testing purposes.
149 data MockIO = MockIO
150 { machineIn :: [Int8]
151 -- ^ Every time the machine executes an 'In' instruction, input will be taken from this list.
152 , machineOut :: [Int8]
153 -- ^ Every time the machine executes an 'Out' instruction, output will be put into this list, in LIFO order.
154 } deriving (Show, Eq, Generic, NFData)
155
156 -- | Create a 'MockIO' that will have the given input available.
157 mkMockIO :: [Int8] -> MockIO
158 mkMockIO input = MockIO {machineIn = input, machineOut = []}
159
160 -- | Create a 'MockIO' that will have the given input available. ASCII encoding.
161 mkMockIOS :: String -> MockIO
162 mkMockIOS = mkMockIO . map (fromIntegral . ord)
163
164 -- | Get the output after a VM has ran using this 'MockIO'.
165 mockOutput :: MockIO -> [Int8]
166 mockOutput = reverse . machineOut
167
168 -- | Get the output after a VM has ran using this 'MockIO'. ASCII encoding.
169 mockOutputS :: MockIO -> String
170 mockOutputS = map (chr . fromIntegral) . mockOutput
171
172 -- | 'StateT' takes its input and output from the lists inside the 'MockIO'.
173 instance Monad m => MachineIO (StateT MockIO m) where
174 putByte :: Int8 -> StateT MockIO m ()
175 putByte b = modify update
176 where
177 update st@MockIO {..} = st {machineOut = b : machineOut}
178 getByte :: StateT MockIO m (Maybe Int8)
179 getByte = do
180 st@MockIO {..} <- get
181 maybe (pure Nothing) (update st) $ uncons machineIn
182 where
183 update st (b, bs) = put st {machineIn = bs} >> return (Just b)
184
185 -- * Helper Functions
186 -- | '<$>' with arguments reversed.
187 (<&>) :: Functor f => f a -> (a -> b) -> f b
188 (<&>) = flip (<$>)
189
190 -- | Helper function to convert a 'Right' into a 'Just' and a 'Left' into a 'Nothing'.
191 eitherToMaybe :: Either a b -> Maybe b
192 eitherToMaybe (Right b) = Just b
193 eitherToMaybe (Left _) = Nothing