blob: 08736cc217abe1691ecce33218834b0e6120cae1 (
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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Types where
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.Map as M
import qualified Data.List as L
import Utils
newtype LException = LException String
data Config = Config {
configScriptFileName :: Maybe String,
configVerboseMode :: Bool,
configShowHelp :: Bool
}
type LContext a = ReaderT Config (ExceptT LException IO) a
type Env = M.Map String AST
type LFunction = (Env -> AST -> LContext AST)
data AST
= ASTInteger Int
| ASTDouble Double
| ASTSymbol String
| ASTBoolean Bool
| ASTString String
| ASTVector [AST]
| ASTFunctionCall [AST]
| ASTHashMap (M.Map AST AST)
| ASTFunction LFunction
| ASTUnit
instance (Show AST) where
show (ASTInteger n) = show n
show (ASTDouble n) = show n
show (ASTSymbol s) = s
show (ASTBoolean b) = show b
show (ASTString s) = show s
show (ASTVector v) = "[" ++ L.intercalate " " (map show v) ++ "]"
show (ASTFunctionCall v) = "(" ++ L.intercalate " " (map show v) ++ ")"
show (ASTHashMap m) =
let flattenMap = M.assocs .> L.concatMap (\(k, v) -> [k, v])
in "{" ++ L.intercalate " " (map show $ flattenMap m) ++ "}"
show (ASTFunction _) = "<fn>"
show ASTUnit = "<unit>"
instance (Eq AST) where
ASTInteger a == ASTInteger b = a == b
ASTDouble a == ASTDouble b = a == b
ASTSymbol a == ASTSymbol b = a == b
ASTBoolean a == ASTBoolean b = a == b
ASTString a == ASTString b = a == b
ASTVector a == ASTVector b = a == b
ASTHashMap a == ASTHashMap b = a == b
ASTUnit == ASTUnit = True
_ == _ = False
instance (Ord AST) where
ASTInteger a <= ASTInteger b = a <= b
ASTDouble a <= ASTDouble b = a <= b
ASTSymbol a <= ASTSymbol b = a <= b
ASTBoolean a <= ASTBoolean b = a <= b
ASTString a <= ASTString b = a <= b
ASTVector a <= ASTVector b = a <= b
ASTHashMap a <= ASTHashMap b = a <= b
_ <= _ = False
assertIsASTFunction :: AST -> LContext AST
assertIsASTFunction ast = case ast of
(ASTFunction _) -> return ast
_ -> throwError $ LException $ show ast ++ " is not a function"
assertIsASTInteger :: AST -> LContext AST
assertIsASTInteger ast = case ast of
(ASTInteger _) -> return ast
_ -> throwError $ LException $ show ast ++ " is not an integer"
assertIsASTSymbol :: AST -> LContext AST
assertIsASTSymbol ast = case ast of
(ASTSymbol _) -> return ast
_ -> throwError $ LException $ show ast ++ " is not a symbol"
assertIsASTVector :: AST -> LContext AST
assertIsASTVector ast = case ast of
(ASTVector _) -> return ast
_ -> throwError $ LException $ show ast ++ " is not a vector"
assertIsASTFunctionCall :: AST -> LContext AST
assertIsASTFunctionCall ast = case ast of
(ASTFunctionCall _) -> return ast
_ -> throwError $ LException $ show ast ++ " is not a function call or body"
|
