git.iko.soy/rowtype-yoga/purescript-native
on 0c961be help sign in
rowtype-yoga/purescript-native/src/PureScript/Parser/Values.hs
228 lines 9.5 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 () Bool
31booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
33parseNumericLiteral :: P.Parsec String () Value
34parseNumericLiteral = NumericLiteral <$> C.naturalOrFloat
36parseStringLiteral :: P.Parsec String () Value
37parseStringLiteral = StringLiteral <$> C.stringLiteral
39parseBooleanLiteral :: P.Parsec String () Value
40parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
42parseArrayLiteral :: P.Parsec String () Value
43parseArrayLiteral = ArrayLiteral <$> (C.squares $ C.commaSep parseValue)
45parseObjectLiteral :: P.Parsec String () Value
46parseObjectLiteral = ObjectLiteral <$> (C.braces $ C.commaSep parseIdentifierAndValue)
48parseIdentifierAndValue :: P.Parsec String () (String, Value)
49parseIdentifierAndValue = do
50 name <- C.lexeme C.identifier
51 C.colon
52 value <- parseValue
53 return (name, value)
55parseAbs :: P.Parsec String () Value
56parseAbs = do
57 C.lexeme $ P.char '\\'
58 args <- C.commaSep C.parseIdent
59 C.lexeme $ P.string "->"
60 value <- parseValue
61 return $ Abs args value
63parseApp :: P.Parsec String () Value
64parseApp = App <$> parseValue
65 <*> (C.parens $ C.commaSep parseValue)
67parseVar :: P.Parsec String () Value
68parseVar = Var <$> C.parseIdent
70parseConstructor :: P.Parsec String () Value
71parseConstructor = Constructor <$> C.properName
73parseCase :: P.Parsec String () Value
74parseCase = Case <$> P.between (C.reserved "case") (C.reserved "of") parseValue
75 <*> C.braces (C.semiSep parseCaseAlternative)
77parseCaseAlternative :: P.Parsec String () (Binder, Value)
78parseCaseAlternative = (,) <$> (parseBinder <* C.lexeme (P.string "->")) <*> parseValue
80parseBlock :: P.Parsec String () Value
81parseBlock = Block <$> (C.braces $ P.many (parseStatement True))
83parseValueAtom :: P.Parsec String () Value
84parseValueAtom = P.choice $ map P.try
85 [ parseNumericLiteral
86 , parseStringLiteral
87 , parseBooleanLiteral
88 , parseArrayLiteral
89 , parseObjectLiteral
90 , parseAbs
91 , parseVar
92 , parseConstructor
93 , parseBlock
94 , parseCase
95 , C.parens parseValue ]
97parseValue :: P.Parsec String () Value
98parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.lexeme funArgs) App
99 where
100 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue
101 funArgs = C.parens $ C.commaSep parseValue
102 parseTypeAnnotation = C.lexeme (P.string "::") *> parsePolyType
103 operators = [ [ Postfix $ Accessor <$> (C.dot *> C.identifier)
104 , Postfix $ Indexer <$> C.squares parseValue ]
105 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)
106 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)
107 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]
108 , [ Infix (C.lexeme (C.parseIdentInfix >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocRight ]
109 , [ Infix (C.lexeme (P.try (P.string "<=")) >> return (Binary LessThanOrEqualTo)) AssocRight
110 , Infix (C.lexeme (P.try (P.string ">=")) >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
111 , [ Infix (C.lexeme (P.try (P.char '<' <* P.notFollowedBy (P.char '<'))) >> return (Binary LessThan)) AssocRight
112 , Infix (C.lexeme (P.try (P.char '>' <* P.notFollowedBy (P.char '>'))) >> return (Binary GreaterThan)) AssocRight ]
113 , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight
114 , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight
115 , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]
116 , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight
117 , Infix (C.lexeme (P.char '+') >> return (Binary Add)) AssocRight
118 , Infix (C.lexeme (P.char '-') >> return (Binary Subtract)) AssocRight ]
119 , [ Infix (C.lexeme (P.string "<<") >> return (Binary ShiftLeft)) AssocRight
120 , Infix (C.lexeme (P.try (P.string ">>>")) >> return (Binary ZeroFillShiftRight)) AssocRight
121 , Infix (C.lexeme (P.string ">>") >> return (Binary ShiftRight)) AssocRight ]
122 , [ Infix (C.lexeme (P.string "==") >> return (Binary EqualTo)) AssocRight
123 , Infix (C.lexeme (P.try (P.string "!=")) >> return (Binary NotEqualTo)) AssocRight ]
124 , [ Infix (C.lexeme (P.try (P.char '&' <* P.notFollowedBy (P.char '&'))) >> return (Binary BitwiseAnd)) AssocRight ]
125 , [ Infix (C.lexeme (P.char '^') >> return (Binary BitwiseXor)) AssocRight ]
126 , [ Infix (C.lexeme (P.try (P.char '|' <* P.notFollowedBy (P.char '|'))) >> return (Binary BitwiseOr)) AssocRight ]
127 , [ Infix (C.lexeme (P.string "&&") >> return (Binary And)) AssocRight ]
128 , [ Infix (C.lexeme (P.string "||") >> return (Binary Or)) AssocRight ]
129 ]
131parseVariableIntroduction :: Bool -> P.Parsec String () Statement
132parseVariableIntroduction requireSemi = do
133 C.reserved "var"
134 name <- C.parseIdent
135 C.lexeme $ P.char '='
136 value <- parseValue
137 when requireSemi (void C.semi)
138 return $ VariableIntroduction name value
140parseAssignment :: Bool -> P.Parsec String () (Statement)
141parseAssignment requireSemi = do
142 tgt <- parseAssignmentTarget
143 C.lexeme $ P.char '='
144 value <- parseValue
145 when requireSemi (void C.semi)
146 return $ Assignment tgt value
148parseManyStatements :: P.Parsec String () [Statement]
149parseManyStatements = C.braces $ P.many (parseStatement True)
151parseWhile :: P.Parsec String () Statement
152parseWhile = While <$> (C.reserved "while" *> C.parens parseValue)
153 <*> parseManyStatements
155parseFor :: P.Parsec String () Statement
156parseFor = For <$> (C.reserved "for" *> C.parens forIntro)
157 <*> parseManyStatements
158 where
159 forIntro = (,,) <$> parseStatement False
160 <*> (C.semi *> parseValue)
161 <*> (C.semi *> parseStatement False)
163parseIfThenElse :: P.Parsec String () Statement
164parseIfThenElse = IfThenElse
165 <$> (C.reserved "if" *> C.parens parseValue)
166 <*> parseManyStatements
167 <*> P.optionMaybe (C.reserved "else" *> parseManyStatements)
169parseReturn :: Bool -> P.Parsec String () Statement
170parseReturn requireSemi = Return <$> (C.reserved "return" *> parseValue <* when requireSemi (void C.semi))
172parseStatement :: Bool -> P.Parsec String () Statement
173parseStatement requireSemi = P.choice $ map P.try
174 [ parseVariableIntroduction requireSemi
175 , parseAssignment requireSemi
176 , parseWhile
177 , parseFor
178 , parseIfThenElse
179 , parseReturn requireSemi ]
181parseStringBinder :: P.Parsec String () Binder
182parseStringBinder = StringBinder <$> C.stringLiteral
184parseBooleanBinder :: P.Parsec String () Binder
185parseBooleanBinder = BooleanBinder <$> booleanLiteral
187parseNumberBinder :: P.Parsec String () Binder
188parseNumberBinder = NumberBinder <$> C.naturalOrFloat
190parseVarBinder :: P.Parsec String () Binder
191parseVarBinder = VarBinder <$> C.parseIdent
193parseNullaryBinder :: P.Parsec String () Binder
194parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
196parseUnaryBinder :: P.Parsec String () Binder
197parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> parseBinder
199parseObjectBinder :: P.Parsec String () Binder
200parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep parseIdentifierAndBinder)
202parseArrayBinder :: P.Parsec String () Binder
203parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep parseBinder) <*> P.optionMaybe (C.colon *> parseBinder)
205parseIdentifierAndBinder :: P.Parsec String () (String, Binder)
206parseIdentifierAndBinder = do
207 name <- C.lexeme C.identifier
208 C.lexeme $ P.char '='
209 binder <- parseBinder
210 return (name, binder)
212parseBinder :: P.Parsec String () Binder
213parseBinder = P.choice $ map P.try
214 [ parseStringBinder
215 , parseBooleanBinder
216 , parseNumberBinder
217 , parseVarBinder
218 , parseUnaryBinder
219 , parseNullaryBinder
220 , parseObjectBinder
221 , parseArrayBinder
222 , C.parens parseBinder ]
224parseAssignmentTarget :: P.Parsec String () AssignmentTarget
225parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.parseIdent)
226 where
227 operators = [ [ Postfix $ AssignArrayIndex <$> C.squares parseValue
228 , Postfix $ AssignObjectProperty <$> (C.dot *> C.identifier) ] ]