blob: 4331ccbf4a1fe0d86a9759043a186bb6828d6dbf (
plain) (
blame)
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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
-- vim: et ts=2 sw=2 ai:
{-# LANGUAGE LambdaCase #-}
module SPL.Parse (parse)
where
import Control.Applicative
import Control.Monad
import Data.Functor
import Text.Parsec (sepBy, (<?>))
import qualified Text.Parsec as P
import SPL.Syntax hiding (TInt,TBool,TChar,TArrow)
import qualified SPL.Syntax
import SPL.Lex
type Parser t = P.Parsec [Token] () t
satisfy :: (Token -> Bool) -> Parser Token
satisfy p = P.tokenPrim
show
(const . const)
(\t -> if p t then Just t else Nothing)
token :: Token -> Parser Token
token t = satisfy (== t) <?> show t
check :: (Token -> Maybe a) -> Parser a
check f = P.tokenPrim
show
(const . const)
f
parse :: [Token] -> Either P.ParseError Program
parse = P.parse spl "Not a valid program" . filter (not . isCommentToken)
spl :: Parser Program
spl = collect <$> (many toplevel <* P.eof)
where
collect :: [Either Variable Function] -> Program
collect vfs = Program [f | Right f <- vfs] [v | Left v <- vfs]
toplevel :: Parser (Either Variable Function)
toplevel = Left <$> var <|> Right <$> fun
comment :: Parser String
comment = toString <$> satisfy isCommentToken
where
toString (TSingleComment s) = s
toString (TBlockComment s) = s
parenthesised :: Parser a -> Parser a
parenthesised p = token TParenOpen *> p <* token TParenClose
braced :: Parser a -> Parser a
braced p = token TBraceOpen *> p <* token TBraceClose
var :: Parser Variable
var = do
t <- Just <$> plainType <|> (token TVar $> Nothing)
id <- ident
token TEquals
val <- expr
token TSemicolon
return $ Variable id t val
fun :: Parser Function
fun = do
id <- ident
args <- parenthesised $ ident `sepBy` token TComma
ftype <- optional (token TColonColon *> funType)
token TBraceOpen
vars <- many var
stmt <- statements
token TBraceClose
return $ Function id ftype args vars stmt
ident :: Parser Name
ident = (\(TIdent id) -> id) <$> satisfy isIdentToken
funType :: Parser Type
funType = do
argtypes <- many plainType
token TArrow
rettype <- plainType
return $ SPL.Syntax.TArrow argtypes rettype
plainType :: Parser Type
plainType = -- TODO
token TIntType $> SPL.Syntax.TInt <|>
token TBoolType $> SPL.Syntax.TBool <|>
token TCharType $> SPL.Syntax.TChar
expr :: Parser Expression
expr = literal -- TODO
where
literal :: Parser Expression
literal = fmap Literal $ check $ \case
TInt i -> Just (LInt i)
TBool b -> Just (LBool b)
_ -> Nothing
statements :: Parser Statement
statements = foldr1 Seq <$> some statement <|> pure Nop
statement :: Parser Statement
statement =
liftM3 If
(token TIf *> parenthesised expr)
(braced statements)
(optional (token TElse *> braced statements)) <|>
liftM2 While
(token TWhile *> parenthesised expr)
(braced statements) <|>
liftM2 Assign
ident
(token TEquals *> expr <* token TSemicolon) <|>
Eval <$> (expr <* token TSemicolon) <|>
Return <$> (token TReturn *> optional expr <* token TSemicolon)
|
