never executed always true always false
1 module HelVM.HelMA.Automaton.IO.MockIO (
2 ioExecMockIOBatch,
3 ioExecMockIOWithInput,
4
5 safeExecMockIOBatch,
6 safeExecMockIOWithInput,
7
8 execMockIOBatch,
9 execMockIOWithInput,
10
11 runMockIO,
12 createMockIO,
13 calculateOutput,
14 calculateLogged,
15
16 MockIO,
17 MockIOData,
18 ) where
19
20 import HelVM.HelMA.Automaton.API.IOTypes
21 import HelVM.HelMA.Automaton.IO.BusinessIO
22
23 import HelVM.HelIO.Control.Control
24 import HelVM.HelIO.Control.Safe
25
26 import HelVM.HelIO.ListLikeExtra
27
28 import qualified Data.ByteString.Lazy as LBS
29
30 import Data.Text as Text
31 import qualified Data.Text.Lazy as LT
32
33 ioExecMockIOBatch :: ControlT MockIO () -> IO MockIOData
34 ioExecMockIOBatch = ioExecMockIOWithInput ""
35
36 ioExecMockIOWithInput :: Input -> ControlT MockIO () -> IO MockIOData
37 ioExecMockIOWithInput i = safeToIO . safeExecMockIOWithInput i
38
39 safeExecMockIOBatch :: ControlT MockIO () -> Safe MockIOData
40 safeExecMockIOBatch = safeExecMockIOWithInput ""
41
42 safeExecMockIOWithInput :: Input -> ControlT MockIO () -> Safe MockIOData
43 safeExecMockIOWithInput i = pure . runMockIO i . runControlT
44
45 execMockIOBatch :: MockIO () -> MockIOData
46 execMockIOBatch = execMockIOWithInput ""
47
48 execMockIOWithInput :: Input -> MockIO () -> MockIOData
49 execMockIOWithInput i a = runMockIO i $ safeWithMessages <$> a
50
51 ----
52
53 runMockIO :: Input -> MockIO UnitSafeWithMessages -> MockIOData
54 runMockIO i mockIO = flip mockDataLogStr mockIOData $ safeWithMessagesToText s
55 where (s , mockIOData) = runState mockIO $ createMockIO i
56
57 createMockIO :: Input -> MockIOData
58 createMockIO i = MockIOData (toString i) "" ""
59
60 calculateOutput :: MockIOData -> Output
61 calculateOutput = calculateText . output
62
63 calculateLogged :: MockIOData -> Output
64 calculateLogged = calculateText . logged
65
66 ----
67
68 instance BusinessIO MockIO where
69 wGetContentsBS = mockGetContentsBS
70 wGetContentsText = mockGetContentsText
71 wGetContents = mockGetContents
72 wGetChar = mockGetChar
73 wGetLine = mockGetLine
74 wPutChar = mockPutChar
75 wPutStr = mockPutStr
76 wLogStr = mockLogStr
77
78 instance BusinessIO (SafeT MockIO) where
79 wGetContentsBS = safeT mockGetContentsBS
80 wGetContentsText = safeT mockGetContentsText
81 wGetContents = safeT mockGetContents
82 wGetChar = safeT mockGetChar
83 wGetLine = safeT mockGetLine
84 wPutChar = safeT . mockPutChar
85 wPutStr = safeT . mockPutStr
86 wLogStr = safeT . mockLogStr
87
88 instance BusinessIO (ControlT MockIO) where
89 wGetContentsBS = controlT mockGetContentsBS
90 wGetContentsText = controlT mockGetContentsText
91 wGetContents = controlT mockGetContents
92 wGetChar = mockGetCharSafe
93 wGetLine = mockGetLineSafe
94 wPutChar = controlT . mockPutChar
95 wPutStr = controlT . mockPutStr
96 wLogStr = controlT . mockLogStr
97
98 ----
99
100 mockGetContentsBS :: MonadMockIO m => m LBS.ByteString
101 mockGetContentsBS = fromStrict . encodeUtf8 <$> mockGetContentsText
102
103 mockGetContentsText :: MonadMockIO m => m LT.Text
104 mockGetContentsText = fromStrict . toText <$> mockGetContents
105
106 mockGetContents :: MonadMockIO m => m String
107 mockGetContents = mockGetContents' =<< get where
108 mockGetContents' :: MonadMockIO m => MockIOData -> m String
109 mockGetContents' mockIO = content <$ put mockIO { input = "" } where content = input mockIO
110
111 mockGetChar :: MonadMockIO m => m Char
112 mockGetChar = mockGetChar' =<< get where
113 mockGetChar' :: MonadMockIO m => MockIOData -> m Char
114 mockGetChar' mockIO = orErrorTuple ("mockGetChar" , show mockIO) (top (input mockIO)) <$ put mockIO { input = orErrorTuple ("mockGetChar" , show mockIO) $ discard $ input mockIO }
115
116 mockGetLine :: MonadMockIO m => m Text
117 mockGetLine = mockGetLine' =<< get where
118 mockGetLine' :: MonadMockIO m => MockIOData -> m Text
119 mockGetLine' mockIO = toText line <$ put mockIO { input = input' } where (line , input') = splitStringByLn $ input mockIO
120
121 mockGetCharSafe :: MonadControlMockIO m => m Char
122 mockGetCharSafe = mockGetChar' =<< get where
123 mockGetChar' :: MonadControlMockIO m => MockIOData -> m Char
124 mockGetChar' mockIO = appendErrorTuple ("mockGetCharSafe" , show mockIO) $ mockGetChar'' =<< unconsSafe (input mockIO) where
125 mockGetChar'' (c, input') = put mockIO { input = input' } $> c
126
127 mockGetLineSafe :: MonadControlMockIO m => m Text
128 mockGetLineSafe = mockGetLine' =<< get where
129 mockGetLine' :: MonadControlMockIO m => MockIOData -> m Text
130 mockGetLine' mockIO = toText line <$ put mockIO { input = input' } where (line , input') = splitStringByLn $ input mockIO
131
132
133 mockPutChar :: Char -> MockIO ()
134 mockPutChar = modify . mockDataPutChar
135
136 mockPutStr :: Text -> MockIO ()
137 mockPutStr = modify . mockDataPutStr
138
139 mockLogStr :: Text -> MockIO ()
140 mockLogStr = modify . mockDataLogStr
141
142 ----
143
144 mockDataPutChar :: Char -> MockIOData -> MockIOData
145 mockDataPutChar char mockIO = mockIO { output = char : output mockIO }
146
147 mockDataPutStr :: Text -> MockIOData -> MockIOData
148 mockDataPutStr text mockIO = mockIO { output = calculateString text <> output mockIO }
149
150 mockDataLogStr :: Text -> MockIOData -> MockIOData
151 mockDataLogStr text mockIO = mockIO { logged = calculateString text <> logged mockIO }
152
153 ----
154
155 type MonadControlMockIO m = (MonadMockIO m , MonadControl m)--FIXME
156
157 --type MonadSafeMockIO m = (MonadMockIO m , MonadSafe m) --FIXME
158
159 type MonadMockIO m = MonadState MockIOData m
160
161 type MockIO = State MockIOData
162
163 calculateText :: String -> Output
164 calculateText = Text.reverse . toText
165
166 calculateString :: Output -> String
167 calculateString = toString . Text.reverse
168
169 data MockIOData = MockIOData
170 { input :: !String
171 , output :: !String
172 , logged :: !String
173 }
174 deriving stock (Eq , Read , Show)
175
176 ----
177
178 splitStringByLn :: String -> (String , String)
179 splitStringByLn = splitBy '\n'