blob: afac84a23065953fb074f5491818a0fd48786b4f (
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
|
-- vim: et ts=2 sw=2 ai:
{-# LANGUAGE LambdaCase #-}
module SPL.Parse (parse)
where
import Text.Parsec (sepBy)
import qualified Text.Parsec
import Control.Applicative
import Data.Functor
import SPL.Syntax hiding (TInt,TBool,TChar,TArrow)
import qualified SPL.Syntax
import SPL.Lex
type Parser t = Text.Parsec.Parsec [Token] () t
satisfy :: (Token -> Bool) -> Parser Token
satisfy p = Text.Parsec.tokenPrim
show
(const . const)
(\t -> if p t then Just t else Nothing)
token :: Token -> Parser Token
token = satisfy . (==)
check :: (Token -> Maybe a) -> Parser a
check f = Text.Parsec.tokenPrim
show
(const . const)
f
parse :: [Token] -> Either Text.Parsec.ParseError Program
parse = Text.Parsec.parse spl "Not a valid program" . filter (not . isCommentToken)
spl :: Parser Program
spl = collect <$> (many toplevel <* Text.Parsec.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
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
token TParenOpen
args <- ident `sepBy` token TComma
token TParenClose
ftype <- optional (token TColonColon *> funType)
token TBraceOpen
vars <- many var
stmt <- statement
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
statement :: Parser Statement
statement = fail "" -- TODO
|
