blob: 75d38afa0e2f7784673c6574a0f7cbf5d2b542a9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
module DSL.Util where
import Data.Map.Strict (empty, member, insert, toList)
import DSL.Types
tAny :: TypeCheck
tAny = const True
tBool :: TypeCheck
tBool (StackBool _) = True
tBool _ = False
tInt :: TypeCheck
tInt (StackInt _) = True
tInt _ = False
tString :: TypeCheck
tString (StackString _) = True
tString _ = False
runChecks :: [TypeCheck] -> Stack -> Maybe String
runChecks fs s
| length fs > length s = Just "stack underflow"
| not (and $ zipWith id fs s) = Just "type mis-match"
| otherwise = Nothing
hcf :: Machine -> String -> IO Machine
hcf m msg = putStrLn msg >> return m{ ok=False }
appendProcTable :: [ProcSpec] -> ProcTable -> Maybe ProcTable
appendProcTable x y = go x
where
go [] = Just y
go ((n, bs):ps) = go ps >>= f
where
f acc
| member n acc = Nothing
| otherwise = Just $ insert n bs acc
mergeProcTables :: ProcTable -> ProcTable -> Maybe ProcTable
mergeProcTables x = appendProcTable $ toList x
buildProcTable :: [ProcSpec] -> Maybe ProcTable
buildProcTable ps = appendProcTable ps empty
unreachable :: a
unreachable = error "this branch should be unreachable"
|
