blob: b60fdc95d72cd414cb06b58f35ad89c73c9beeb7 (
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
|
module Parser (
parse,
) where
import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.Maybe as MB
import Control.Monad.Except
import Text.Regex.TDFA
import Utils
validateBalance :: [String] -> [AST] -> LContext [AST]
validateBalance allowed asts = do
when (ASTSymbol "(" `elem` astNodes && "(" `notElem` allowed)
$ throwL "unbalanced function call"
when (ASTSymbol "[" `elem` astNodes && "[" `notElem` allowed)
$ throwL "unbalanced vector"
when (ASTSymbol "{" `elem` astNodes && "{" `notElem` allowed)
$ throwL "unbalanced hash map"
return asts
where
astNodes = map astNode asts
parseToken :: Token -> AST
parseToken (Token token tr tc tf)
| isInteger token = ast $ ASTInteger (read token)
| isDouble token = ast $ ASTDouble (read token)
| isString token = ast $ ASTString $ removeQuotes token
| isBoolean token = ast $ ASTBoolean $ asBoolean token
| otherwise = ast $ ASTSymbol token
where
integerRegex = "^-?[[:digit:]]+$"
isInteger :: String -> Bool
isInteger t = t =~ integerRegex
doubleRegex = "^-?[[:digit:]]+(\\.[[:digit:]]+)?$"
isDouble :: String -> Bool
isDouble t = t =~ doubleRegex
isString t = "\"" `L.isPrefixOf` t
removeQuotes s = drop 1 s $> take (length s - 2)
isBoolean t = t `elem` ["true", "false"]
asBoolean t = if t == "true" then True else False
ast astNode = AST { astNode = astNode, astRow = tr, astColumn = tc, astFileName = tf }
_parse :: [AST] -> [Token] -> LContext [AST]
_parse acc' [] = do
acc <- validateBalance [] acc'
return $ reverse acc
_parse acc (Token { tokenContent = ")" }:rest) = do
let children' = takeWhile (astNode .> (/= ASTSymbol "(")) acc
children <- validateBalance ["("] children'
let openParen = MB.fromJust $ L.find (astNode .> (== ASTSymbol "(")) acc
let fnCall = openParen { astNode = ASTFunctionCall (reverse children) }
let newAcc = fnCall : drop (length children + 1) acc
_parse newAcc rest
_parse acc (Token { tokenContent = "]" }:rest) = do
let children' = takeWhile (astNode .> (/= ASTSymbol "[")) acc
children <- validateBalance ["["] children'
let openBracket = MB.fromJust $ L.find (astNode .> (== ASTSymbol "[")) acc
let vec = openBracket { astNode = ASTVector (reverse children) }
let newAcc = vec : drop (length children + 1) acc
_parse newAcc rest
_parse acc (Token { tokenContent = "}" }:rest) = do
let children' = takeWhile (astNode .> (/= ASTSymbol "{")) acc
children <- validateBalance ["{"] children'
pairs <- asPairsM $ reverse children
let openCurly = MB.fromJust $ L.find (astNode .> (== ASTSymbol "{")) acc
let hmap = openCurly { astNode = ASTHashMap (M.fromList pairs) }
let newAcc = hmap : drop (length children + 1) acc
_parse newAcc rest
_parse acc (token:rest) =
_parse (parseToken token : acc) rest
parse :: [Token] -> LContext [AST]
parse = _parse []
|
