never executed always true always false
1 module HelVM.HelMA.Automaton.Combiner.ALU (
2 runALI,
3 runSAL,
4
5 outputCharMaybe,
6 outputDecMaybe,
7
8 outputChar,
9 outputDec,
10 inputChar,
11 inputDec,
12 lNot,
13 divMod,
14 sub,
15 binaryInstruction,
16 binaryInstructions,
17 roll,
18 halibut,
19 move,
20 rollImediate,
21 discard,
22 slide,
23 copy,
24 flipPush1,
25 charPush1,
26 genericPush1,
27 pop1,
28 pop2,
29 push1,
30 push2,
31 splitAt,
32 drop,
33 ALU,
34 SafeStack,
35 Stack,
36 ) where
37
38 import HelVM.HelMA.Automaton.Instruction.Extras.Common
39
40 import HelVM.HelMA.Automaton.Instruction.Groups.IOInstruction
41 import HelVM.HelMA.Automaton.Instruction.Groups.SMInstruction
42
43 import HelVM.HelMA.Automaton.Eff.MonadEff
44
45 import HelVM.HelIO.Control.Safe
46
47 import HelVM.HelIO.Containers.LLIndexSafe
48
49 import HelVM.HelIO.ListLikeExtra
50
51 import Control.Applicative.Tools
52 import Data.ListLike hiding (show)
53 import Prelude hiding (divMod, drop, fromList, length, splitAt, swap, uncons)
54
55
56 runALI :: ALU m ll element => SMInstruction -> ll -> m ll
57 runALI (SPure ali) = runSAL ali
58 runALI (SIO ioi) = runSIO ioi
59
60 runSIO :: ALU m ll element => IOInstruction -> ll -> m ll
61 runSIO OutputChar = outputChar
62 runSIO OutputDec = outputDec
63 runSIO InputChar = inputChar
64 runSIO InputDec = inputDec
65
66 runSAL :: SafeStack m ll element => SPureInstruction -> ll -> m ll
67 runSAL (Cons i ) = push i
68 runSAL (Unary op ) = unaryInstruction op
69 runSAL (Binary op ) = binaryInstruction op
70 runSAL (Binaries ops ) = binaryInstructions ops
71 runSAL (Indexed t op) = indexedInstruction op t
72 runSAL Halibut = halibut
73 runSAL Pick = pick
74 runSAL Discard = discard
75
76 -- | Arithmetic instructions
77 unaryInstruction :: SafeStack m ll element => UnaryOperation -> ll -> m ll
78 unaryInstruction (UImmediate i op) = build <.> pop1 where
79 build (e , l) = push1 (calculateOp (fromInteger i) e op) l
80 unaryInstruction LNot = lNot
81 unaryInstruction op = error $ show op
82
83 lNot :: SafeStack m ll element => ll -> m ll
84 lNot = build <.> pop1 where
85 build (e , l) = push1 (go e) l
86 go 0 = 1
87 go _ = 0
88
89 divMod :: SafeStack m ll element => ll -> m ll
90 divMod = binaryInstructions [Mod , Div]
91
92 sub :: SafeStack m ll element => ll -> m ll
93 sub = binaryInstruction Sub
94
95 binaryInstruction :: SafeStack m ll element => BinaryOperation -> ll -> m ll
96 binaryInstruction i = binaryInstructions [i]
97
98 binaryInstructions :: SafeStack m ll element => [BinaryOperation] -> ll -> m ll
99 binaryInstructions il = build <.> pop2 where
100 build (e , e', l) = pushList (calculateOps e e' il) l
101
102 -- | IO instructions
103 outputCharMaybe :: ALU m ll element => ll -> m ll
104 outputCharMaybe = appendError "ALU.outputCharMaybe" . outputMaybe putAsChar
105
106 outputDecMaybe :: ALU m ll element => ll -> m ll
107 outputDecMaybe = appendError "ALU.outputDecMaybe" .outputMaybe putAsDec
108
109 outputMaybe :: ALU m ll element => (element -> m ()) -> ll -> m ll
110 outputMaybe putAs l = maybe (pure l) f (uncons l) where f = uncurry $ flip (<$) . putAs
111
112 outputChar :: ALU m ll element => ll -> m ll
113 outputChar = appendError "ALU.outputChar" . build <=< pop1 where
114 build (e , l) = putAsChar e $> l
115
116 outputDec :: ALU m ll element => ll -> m ll
117 outputDec = appendError "ALU.outputDec" . build <=< pop1 where
118 build (e , l) = putAsDec e $> l
119
120 inputChar :: ALU m ll element => ll -> m ll
121 inputChar l = appendError "ALU.inputChar" $ build <$> getCharAs where
122 build e = push1 e l
123
124 inputDec :: ALU m ll element => ll -> m ll
125 inputDec l = appendError "ALU.inputDec" $ build <$> getDecAs where
126 build e = push1 e l
127
128 indexedInstruction :: SafeStack m ll element => IndexedOperation -> IndexOperand -> ll -> m ll
129 indexedInstruction i ITop = indexedInstructionTop i
130 indexedInstruction i (IImmediate n) = indexedInstructionImmediate i n
131
132 -- | Indexed instructions
133 indexedInstructionTop :: SafeStack m ll element => IndexedOperation -> ll -> m ll
134 indexedInstructionTop op = appendError "ALU.indexedInstructionTop" . build <=< unconsSafe where
135 build (e , l) = indexedInstructionImmediate op (fromIntegral e) l
136
137 indexedInstructionImmediate :: SafeStack m ll element => IndexedOperation -> ImmediateIndex -> ll -> m ll
138 indexedInstructionImmediate Copy = copy
139 indexedInstructionImmediate Move = move
140 indexedInstructionImmediate Slide = slide
141
142 -- | Halibut and Pick instructions
143
144 roll :: SafeStack m ll element => ll -> m ll
145 roll = build <=< pop2 where
146 build (rolls, depth, l) = rollImediate (fromIntegral rolls) (fromIntegral depth) l
147
148 halibut :: SafeStack m ll element => ll -> m ll
149 halibut = appendError "ALU.halibut" . build <=< pop1 where
150 build (e , l)
151 | 0 < i = move i l
152 | otherwise = copy (negate i) l
153 where i = fromIntegral e
154
155 pick :: SafeStack m ll element => ll -> m ll
156 pick = appendError "ALU.pick" . build <=< pop1 where
157 build (e , l)
158 | 0 <= i = copy i l
159 | otherwise = move (negate i) l
160 where i = fromIntegral e
161
162 -- | Slide instructions
163 slide :: SafeStack m ll element => ImmediateIndex -> ll -> m ll
164 slide i = appendError "ALU.pop2" . build <.> pop1 where
165 build (e , l) = push1 e $ drop i l
166
167 move :: SafeStack m ll element => ImmediateIndex -> ll -> m ll
168 move i = rollImediate i (i + 1)
169
170 rollImediate :: SafeStack m ll element => ImmediateIndex -> ImmediateIndex -> ll -> m ll
171 rollImediate rolls i l = build $ length l where
172 build ll
173 | i < 0 = pure l
174 | r == 0 = pure l
175 | ll < i = liftErrorWithTupleList "ALU.role index must be less then lenght" [("i" , show i) , ("ll" , show ll)]
176 | otherwise = pure $ l1 <> l2 <> l3
177 where
178 r = rolls `mod` i
179 (l2, l1) = splitAt r l'
180 (l', l3) = splitAt i l
181
182 -- | Copy instructions
183 copy :: SafeStack m ll element => ImmediateIndex -> ll -> m ll
184 copy i = teeMap flipPush1 (findSafe i)
185
186 -- | Pop instructions
187 pop1 :: SafeStack m ll element => ll -> m (element , ll)
188 pop1 = appendError "ALU.pop1" . unconsSafe
189
190 pop2 :: SafeStack m ll element => ll -> m (element , element , ll)
191 pop2 = appendError "ALU.pop2" . uncons2Safe
192
193 -- | Push instructions
194 push :: SafeStack m ll element => Integer -> ll -> m ll
195 push i = pure . genericPush1 i
196
197 flipPush1 :: Stack ll element => ll -> element -> ll
198 flipPush1 = flip push1
199
200 charPush1 :: (Num element , Stack ll element) => Char -> ll -> ll
201 charPush1 = genericPush1 . ord
202
203 genericPush1 :: (Integral v , Num element , Stack ll element) => v -> ll -> ll
204 genericPush1 = push1 . fromIntegral
205
206 push1 :: Stack ll element => element -> ll -> ll
207 push1 e = pushList [e]
208
209 push2 :: Stack ll element => element -> element -> ll -> ll
210 push2 e e' = pushList [e , e']
211
212 pushList :: Stack ll element => [element] -> ll -> ll
213 pushList es l = fromList es <> l
214
215 teeMap :: Functor f => (t -> a -> b) -> (t -> f a) -> t -> f b
216 teeMap f2 f1 x = f2 x <$> f1 x
217
218 -- | Types
219 type ALU m ll element = (AppEff m , SafeStack m ll element)
220
221 type SafeStack m ll element = (MonadSafe m , IntegralStack ll element)
222
223 type IntegralStack ll element = (Stack ll element , Integral element)
224
225 type Stack ll element = (Show ll , ListLike ll element , IndexSafe ll element)