blob: 6affe75a08e29e60308f3df74fb8c62e4748e282 (
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 -> Either String ProcTable
appendProcTable x y = go x
where
go [] = Right y
go ((n, bs):ps) = go ps >>= f
where
f acc
| member n acc = Left $ "Duplicate PROC definition: " ++ n
| otherwise = Right $ insert n bs acc
mergeProcTables :: ProcTable -> ProcTable -> Either String ProcTable
mergeProcTables x = appendProcTable $ toList x
buildProcTable :: [ProcSpec] -> Either String ProcTable
buildProcTable ps = appendProcTable ps empty
unreachable :: a
unreachable = error "This branch should be unreachable. If you can read this, something has gone EXTREMELY wrong."
|
