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