git.iko.soy/rowtype-yoga/purescript-native
on a10616f help sign in
rowtype-yoga/purescript-native/src/PureScript/Parser/Values.hs
193 lines 7.4 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.Parser.Values
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module PureScript.Parser.Values (
16 parseValue,
17 parseBinder
18) where
20import PureScript.Values
21import qualified PureScript.Parser.Common as C
22import Control.Applicative
23import qualified Text.Parsec as P
24import Text.Parsec.Expr
25import Control.Arrow (Arrow(..))
26import PureScript.Parser.Types
27import PureScript.Types
29parseNumericLiteral :: P.Parsec String () Value
30parseNumericLiteral = NumericLiteral <$> either fromIntegral id <$> C.naturalOrFloat
32parseStringLiteral :: P.Parsec String () Value
33parseStringLiteral = StringLiteral <$> C.stringLiteral
35parseBooleanLiteral :: P.Parsec String () Value
36parseBooleanLiteral = BooleanLiteral <$> ((P.string "true" >> return True)
37 P.<|> (P.string "false" >> return False))
39parseArrayLiteral :: P.Parsec String () Value
40parseArrayLiteral = ArrayLiteral <$> (C.squares $ C.commaSep parseValue)
42parseObjectLiteral :: P.Parsec String () Value
43parseObjectLiteral = ObjectLiteral <$> (C.braces $ C.commaSep parseIdentifierAndValue)
45parseIdentifierAndValue :: P.Parsec String () (String, Value)
46parseIdentifierAndValue = do
47 name <- C.lexeme C.identifier
48 C.colon
49 value <- parseValue
50 return (name, value)
52parseAbs :: P.Parsec String () Value
53parseAbs = do
54 P.char '\\'
55 args <- C.commaSep1 C.identifier
56 C.lexeme $ P.string "->"
57 value <- parseValue
58 return $ Abs args value
60parseApp :: P.Parsec String () Value
61parseApp = App <$> parseValue
62 <*> (C.parens $ C.commaSep parseValue)
64parseVar :: P.Parsec String () Value
65parseVar = Var <$> (C.identifier <|> C.properName)
67parseCase :: P.Parsec String () Value
68parseCase = Case <$> P.between (C.reserved "case") (C.reserved "of") parseValue
69 <*> C.braces (C.semiSep parseCaseAlternative)
71parseCaseAlternative :: P.Parsec String () (Binder, Value)
72parseCaseAlternative = (,) <$> (parseBinder <* C.lexeme (P.string "->")) <*> parseValue
74parseBlock :: P.Parsec String () Value
75parseBlock = Block <$> (C.braces $ P.many parseStatement)
77parseValueAtom :: P.Parsec String () Value
78parseValueAtom = P.choice $ map P.try
79 [ parseNumericLiteral
80 , parseStringLiteral
81 , parseBooleanLiteral
82 , parseArrayLiteral
83 , parseObjectLiteral
84 , parseAbs
85 , parseVar
86 , parseBlock
87 , parseCase
88 , C.parens parseValue ]
90parseValue :: P.Parsec String () Value
91parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.lexeme funArgs) App
92 where
93 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue
94 funArgs = C.parens $ C.commaSep parseValue
95 parseTypeAnnotation = C.lexeme (P.string "::") *> parseType
96 operators = [ [ Postfix $ (Accessor <$> (C.dot *> C.identifier)) ]
97 , [ Infix (C.lexeme (P.try (P.string "||")) >> return (Binary Or)) AssocRight ]
98 , [ Infix (C.lexeme (P.try (P.string "&&")) >> return (Binary And)) AssocRight ]
99 , [ Infix (C.lexeme (P.char '|') >> return (Binary BitwiseOr)) AssocRight ]
100 , [ Infix (C.lexeme (P.char '^') >> return (Binary BitwiseXor)) AssocRight ]
101 , [ Infix (C.lexeme (P.char '&') >> return (Binary BitwiseAnd)) AssocRight ]
102 , [ Infix (C.lexeme (P.string "==") >> return (Binary EqualTo)) AssocRight
103 , Infix (C.lexeme (P.try (P.string "!=")) >> return (Binary NotEqualTo)) AssocRight ]
104 , [ Infix (C.lexeme (P.string "<<") >> return (Binary ShiftLeft)) AssocRight
105 , Infix (C.lexeme (P.try (P.string ">>>")) >> return (Binary ZeroFillShiftRight)) AssocRight
106 , Infix (C.lexeme (P.string ">>") >> return (Binary ShiftRight)) AssocRight ]
107 , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight
108 , Infix (C.lexeme (P.char '+') >> return (Binary Add)) AssocRight
109 , Infix (C.lexeme (P.char '-') >> return (Binary Subtract)) AssocRight ]
110 , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight
111 , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight
112 , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]
113 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)
114 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)
115 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]
116 ]
118parseVariableIntroduction :: P.Parsec String () Statement
119parseVariableIntroduction = do
120 C.reserved "var"
121 name <- C.identifier
122 C.lexeme $ P.char '='
123 value <- parseValue
124 C.semi
125 return $ VariableIntroduction name value
127parseAssignment :: P.Parsec String () (Statement)
128parseAssignment = do
129 tgt <- C.identifier
130 C.lexeme $ P.char '='
131 value <- parseValue
132 C.semi
133 return $ Assignment tgt value
135parseManyStatements :: P.Parsec String () [Statement]
136parseManyStatements = C.braces $ P.many parseStatement
138parseWhile :: P.Parsec String () Statement
139parseWhile = While <$> (C.reserved "while" *> C.parens parseValue)
140 <*> parseManyStatements
142parseFor :: P.Parsec String () Statement
143parseFor = For <$> (C.reserved "for" *> C.parens forIntro)
144 <*> parseManyStatements
145 where
146 forIntro = (,,) <$> parseStatement
147 <*> (C.semi *> parseValue)
148 <*> (C.semi *> parseStatement)
150parseIfThenElse :: P.Parsec String () Statement
151parseIfThenElse = IfThenElse
152 <$> (C.reserved "if" *> C.parens parseValue)
153 <*> parseManyStatements
154 <*> P.optionMaybe (C.reserved "else" *> parseManyStatements)
156parseReturn :: P.Parsec String () Statement
157parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.semi)
159parseStatement :: P.Parsec String () Statement
160parseStatement = P.choice $ map P.try
161 [ parseVariableIntroduction
162 , parseAssignment
163 , parseWhile
164 , parseFor
165 , parseIfThenElse
166 , parseReturn ]
168parseVarBinder :: P.Parsec String () Binder
169parseVarBinder = VarBinder <$> C.lexeme C.identifier
171parseNullaryBinder :: P.Parsec String () Binder
172parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
174parseUnaryBinder :: P.Parsec String () Binder
175parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> parseBinder
177parseObjectBinder :: P.Parsec String () Binder
178parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep parseIdentifierAndBinder)
180parseIdentifierAndBinder :: P.Parsec String () (String, Binder)
181parseIdentifierAndBinder = do
182 name <- C.lexeme C.identifier
183 C.lexeme $ P.char '='
184 binder <- parseBinder
185 return (name, binder)
187parseBinder :: P.Parsec String () Binder
188parseBinder = P.choice $ map P.try
189 [ parseVarBinder
190 , parseUnaryBinder
191 , parseNullaryBinder
192 , parseObjectBinder
193 , C.parens parseBinder ]