git.iko.soy/rowtype-yoga/purescript-native
on 1997015 help sign in
rowtype-yoga/purescript-native/src/PureScript/Parser/Values.hs
255 lines 12 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.Monad
26import Control.Arrow (Arrow(..))
27import PureScript.Parser.Types
28import PureScript.Types
30booleanLiteral :: P.Parsec String P.Column Bool
31booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
33parseNumericLiteral :: P.Parsec String P.Column Value
34parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
36parseStringLiteral :: P.Parsec String P.Column Value
37parseStringLiteral = StringLiteral <$> C.stringLiteral
39parseBooleanLiteral :: P.Parsec String P.Column Value
40parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
42parseArrayLiteral :: P.Parsec String P.Column Value
43parseArrayLiteral = ArrayLiteral <$> (C.squares $ parseValue `P.sepBy` (C.indented *> C.comma))
45parseObjectLiteral :: P.Parsec String P.Column Value
46parseObjectLiteral = ObjectLiteral <$> (C.braces $ parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))
48parseIdentifierAndValue :: P.Parsec String P.Column (String, Value)
49parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
50 <*> (C.indented *> parseValue)
52parseAbs :: P.Parsec String P.Column Value
53parseAbs = do
54 C.lexeme $ P.char '\\'
55 args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)
56 C.lexeme $ C.indented *> P.string "->"
57 value <- parseValue
58 return $ Abs args value
60parseApp :: P.Parsec String P.Column Value
61parseApp = App <$> parseValue
62 <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
64parseVar :: P.Parsec String P.Column Value
65parseVar = Var <$> C.parseIdent
67parseConstructor :: P.Parsec String P.Column Value
68parseConstructor = Constructor <$> C.properName
70parseCase :: P.Parsec String P.Column Value
71parseCase = Case <$> (P.between (C.reserved "case") (C.indented *> C.reserved "of") parseValue)
72 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
74parseCaseAlternative :: P.Parsec String P.Column (Binder, Value)
75parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->")) <*> parseValue
77parseIfThenElse :: P.Parsec String P.Column Value
78parseIfThenElse = IfThenElse <$> (C.reserved "if" *> C.indented *> parseValue)
79 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
80 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
82parseBlock :: P.Parsec String P.Column Value
83parseBlock = Block <$> (C.reserved "do" *> parseManyStatements)
85parseManyStatements :: P.Parsec String P.Column [Statement]
86parseManyStatements = C.indented *> (C.mark $ P.many $ C.same *> C.mark parseStatement)
88parseValueAtom :: P.Parsec String P.Column Value
89parseValueAtom = C.indented *> P.choice (map P.try
90 [ parseNumericLiteral
91 , parseStringLiteral
92 , parseBooleanLiteral
93 , parseArrayLiteral
94 , parseObjectLiteral
95 , parseAbs
96 , parseVar
97 , parseConstructor
98 , parseBlock
99 , parseCase
100 , parseIfThenElse
101 , C.parens parseValue ])
103parseValue :: P.Parsec String P.Column Value
104parseValue = buildExpressionParser operators . C.buildPostfixParser postfixTable2 $ indexersAndAccessors
105 where
106 indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom
107 postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
108 , Indexer <$> (C.indented *> C.squares parseValue) ]
109 postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])
110 , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
111 , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]
112 operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
113 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
114 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
115 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
116 , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix) >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocRight ]
117 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
118 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
119 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight
120 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">") >> return (Binary GreaterThan)) AssocRight ]
121 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "*") >> return (Binary Multiply)) AssocRight
122 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "/") >> return (Binary Divide)) AssocRight
123 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "%") >> return (Binary Modulus)) AssocRight ]
124 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "++") >> return (Binary Concat)) AssocRight
125 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return (Binary Add)) AssocRight
126 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Binary Subtract)) AssocRight ]
127 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<<") >> return (Binary ShiftLeft)) AssocRight
128 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>>") >> return (Binary ZeroFillShiftRight)) AssocRight
129 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>") >> return (Binary ShiftRight)) AssocRight ]
130 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "==") >> return (Binary EqualTo)) AssocRight
131 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!=") >> return (Binary NotEqualTo)) AssocRight ]
132 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&") >> return (Binary BitwiseAnd)) AssocRight ]
133 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "^") >> return (Binary BitwiseXor)) AssocRight ]
134 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "|") >> return (Binary BitwiseOr)) AssocRight ]
135 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&&") >> return (Binary And)) AssocRight ]
136 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]
137 ]
139parseVariableIntroduction :: P.Parsec String P.Column Statement
140parseVariableIntroduction = do
141 C.reserved "var"
142 name <- C.indented *> C.parseIdent
143 C.lexeme $ C.indented *> P.char '='
144 value <- parseValue
145 return $ VariableIntroduction name value
147parseAssignment :: P.Parsec String P.Column Statement
148parseAssignment = do
149 tgt <- parseAssignmentTarget
150 C.lexeme $ C.indented *> P.char '='
151 value <- parseValue
152 return $ Assignment tgt value
154parseWhile :: P.Parsec String P.Column Statement
155parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
156 <*> parseManyStatements
158parseFor :: P.Parsec String P.Column Statement
159parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
160 <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
161 <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
162 <*> parseManyStatements
164parseForEach :: P.Parsec String P.Column Statement
165parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
166 <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
167 <*> parseManyStatements
169parseIf :: P.Parsec String P.Column Statement
170parseIf = If <$> parseIfStatement
172parseIfStatement :: P.Parsec String P.Column IfStatement
173parseIfStatement =
174 IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
175 <*> parseManyStatements
176 <*> P.optionMaybe (C.same *> parseElseStatement)
178parseElseStatement :: P.Parsec String P.Column ElseStatement
179parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
180 <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
182parseReturn :: P.Parsec String P.Column Statement
183parseReturn = Return <$> (C.reserved "return" *> parseValue)
185parseStatement :: P.Parsec String P.Column Statement
186parseStatement = P.choice (map P.try
187 [ parseVariableIntroduction
188 , parseAssignment
189 , parseWhile
190 , parseFor
191 , parseForEach
192 , parseIf
193 , parseReturn ])
195parseStringBinder :: P.Parsec String P.Column Binder
196parseStringBinder = StringBinder <$> C.stringLiteral
198parseBooleanBinder :: P.Parsec String P.Column Binder
199parseBooleanBinder = BooleanBinder <$> booleanLiteral
201parseNumberBinder :: P.Parsec String P.Column Binder
202parseNumberBinder = NumberBinder <$> C.integerOrFloat
204parseVarBinder :: P.Parsec String P.Column Binder
205parseVarBinder = VarBinder <$> C.parseIdent
207parseNullaryBinder :: P.Parsec String P.Column Binder
208parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
210parseUnaryBinder :: P.Parsec String P.Column Binder
211parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)
213parseObjectBinder :: P.Parsec String P.Column Binder
214parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
216parseArrayBinder :: P.Parsec String P.Column Binder
217parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma))
218 <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)
220parseNamedBinder :: P.Parsec String P.Column Binder
221parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
222 <*> (C.indented *> parseBinder)
224parseNullBinder :: P.Parsec String P.Column Binder
225parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
227parseIdentifierAndBinder :: P.Parsec String P.Column (String, Binder)
228parseIdentifierAndBinder = do
229 name <- C.lexeme C.identifier
230 C.lexeme $ C.indented *> P.char '='
231 binder <- C.indented *> parseBinder
232 return (name, binder)
234parseBinder :: P.Parsec String P.Column Binder
235parseBinder = P.choice (map P.try
236 [ parseNullBinder
237 , parseStringBinder
238 , parseBooleanBinder
239 , parseNumberBinder
240 , parseNamedBinder
241 , parseVarBinder
242 , parseUnaryBinder
243 , parseNullaryBinder
244 , parseObjectBinder
245 , parseArrayBinder
246 , C.parens parseBinder ])
248parseGuardedBinder :: P.Parsec String P.Column Binder
249parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
251parseAssignmentTarget :: P.Parsec String P.Column AssignmentTarget
252parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.parseIdent)
253 where
254 operators = [ [ Postfix $ AssignArrayIndex <$> (C.indented *> C.squares parseValue)
255 , Postfix $ AssignObjectProperty <$> (C.indented *> C.dot *> C.indented *> C.identifier) ] ]