git.iko.soy/rowtype-yoga/purescript-native
on 6b2d16b help sign in
rowtype-yoga/purescript-native/src/PureScript/Parser/Values.hs
229 lines 9.7 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 qualified Text.Parsec.Indent as I
25import Text.Parsec.Expr
26import Control.Monad
27import Control.Arrow (Arrow(..))
28import PureScript.Parser.Types
29import PureScript.Types
31booleanLiteral :: I.IndentParser String () Bool
32booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
34parseNumericLiteral :: I.IndentParser String () Value
35parseNumericLiteral = NumericLiteral <$> C.naturalOrFloat
37parseStringLiteral :: I.IndentParser String () Value
38parseStringLiteral = StringLiteral <$> C.stringLiteral
40parseBooleanLiteral :: I.IndentParser String () Value
41parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
43parseArrayLiteral :: I.IndentParser String () Value
44parseArrayLiteral = ArrayLiteral <$> (C.squares $ C.commaSep parseValue)
46parseObjectLiteral :: I.IndentParser String () Value
47parseObjectLiteral = ObjectLiteral <$> (C.braces $ C.commaSep parseIdentifierAndValue)
49parseIdentifierAndValue :: I.IndentParser String () (String, Value)
50parseIdentifierAndValue = do
51 name <- C.lexeme C.identifier
52 C.colon
53 value <- parseValue
54 return (name, value)
56parseAbs :: I.IndentParser String () Value
57parseAbs = do
58 C.lexeme $ P.char '\\'
59 args <- C.commaSep C.parseIdent
60 C.lexeme $ P.string "->"
61 value <- parseValue
62 return $ Abs args value
64parseApp :: I.IndentParser String () Value
65parseApp = App <$> parseValue
66 <*> (C.parens $ C.commaSep parseValue)
68parseVar :: I.IndentParser String () Value
69parseVar = Var <$> C.parseIdent
71parseConstructor :: I.IndentParser String () Value
72parseConstructor = Constructor <$> C.properName
74parseCase :: I.IndentParser String () Value
75parseCase = Case <$> P.between (C.reserved "case") (C.reserved "of") parseValue
76 <*> C.braces (C.semiSep parseCaseAlternative)
78parseCaseAlternative :: I.IndentParser String () (Binder, Value)
79parseCaseAlternative = (,) <$> (parseBinder <* C.lexeme (P.string "->")) <*> parseValue
81parseBlock :: I.IndentParser String () Value
82parseBlock = Block <$> (C.braces $ P.many (parseStatement True))
84parseValueAtom :: I.IndentParser String () Value
85parseValueAtom = P.choice $ map P.try
86 [ parseNumericLiteral
87 , parseStringLiteral
88 , parseBooleanLiteral
89 , parseArrayLiteral
90 , parseObjectLiteral
91 , parseAbs
92 , parseVar
93 , parseConstructor
94 , parseBlock
95 , parseCase
96 , C.parens parseValue ]
98parseValue :: I.IndentParser String () Value
99parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.lexeme funArgs) App
100 where
101 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue
102 funArgs = C.parens $ C.commaSep parseValue
103 parseTypeAnnotation = C.lexeme (P.string "::") *> parsePolyType
104 operators = [ [ Postfix $ Accessor <$> (C.dot *> C.identifier)
105 , Postfix $ Indexer <$> C.squares parseValue ]
106 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)
107 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)
108 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]
109 , [ Infix (C.lexeme (C.parseIdentInfix >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocRight ]
110 , [ Infix (C.lexeme (P.try (P.string "<=")) >> return (Binary LessThanOrEqualTo)) AssocRight
111 , Infix (C.lexeme (P.try (P.string ">=")) >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
112 , [ Infix (C.lexeme (P.try (P.char '<' <* P.notFollowedBy (P.char '<'))) >> return (Binary LessThan)) AssocRight
113 , Infix (C.lexeme (P.try (P.char '>' <* P.notFollowedBy (P.char '>'))) >> return (Binary GreaterThan)) AssocRight ]
114 , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight
115 , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight
116 , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]
117 , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight
118 , Infix (C.lexeme (P.char '+') >> return (Binary Add)) AssocRight
119 , Infix (C.lexeme (P.char '-') >> return (Binary Subtract)) AssocRight ]
120 , [ Infix (C.lexeme (P.string "<<") >> return (Binary ShiftLeft)) AssocRight
121 , Infix (C.lexeme (P.try (P.string ">>>")) >> return (Binary ZeroFillShiftRight)) AssocRight
122 , Infix (C.lexeme (P.string ">>") >> return (Binary ShiftRight)) AssocRight ]
123 , [ Infix (C.lexeme (P.string "==") >> return (Binary EqualTo)) AssocRight
124 , Infix (C.lexeme (P.try (P.string "!=")) >> return (Binary NotEqualTo)) AssocRight ]
125 , [ Infix (C.lexeme (P.try (P.char '&' <* P.notFollowedBy (P.char '&'))) >> return (Binary BitwiseAnd)) AssocRight ]
126 , [ Infix (C.lexeme (P.char '^') >> return (Binary BitwiseXor)) AssocRight ]
127 , [ Infix (C.lexeme (P.try (P.char '|' <* P.notFollowedBy (P.char '|'))) >> return (Binary BitwiseOr)) AssocRight ]
128 , [ Infix (C.lexeme (P.string "&&") >> return (Binary And)) AssocRight ]
129 , [ Infix (C.lexeme (P.string "||") >> return (Binary Or)) AssocRight ]
130 ]
132parseVariableIntroduction :: Bool -> I.IndentParser String () Statement
133parseVariableIntroduction requireSemi = do
134 C.reserved "var"
135 name <- C.parseIdent
136 C.lexeme $ P.char '='
137 value <- parseValue
138 when requireSemi (void C.semi)
139 return $ VariableIntroduction name value
141parseAssignment :: Bool -> I.IndentParser String () (Statement)
142parseAssignment requireSemi = do
143 tgt <- parseAssignmentTarget
144 C.lexeme $ P.char '='
145 value <- parseValue
146 when requireSemi (void C.semi)
147 return $ Assignment tgt value
149parseManyStatements :: I.IndentParser String () [Statement]
150parseManyStatements = C.braces $ P.many (parseStatement True)
152parseWhile :: I.IndentParser String () Statement
153parseWhile = While <$> (C.reserved "while" *> C.parens parseValue)
154 <*> parseManyStatements
156parseFor :: I.IndentParser String () Statement
157parseFor = For <$> (C.reserved "for" *> C.parens forIntro)
158 <*> parseManyStatements
159 where
160 forIntro = (,,) <$> parseStatement False
161 <*> (C.semi *> parseValue)
162 <*> (C.semi *> parseStatement False)
164parseIfThenElse :: I.IndentParser String () Statement
165parseIfThenElse = IfThenElse
166 <$> (C.reserved "if" *> C.parens parseValue)
167 <*> parseManyStatements
168 <*> P.optionMaybe (C.reserved "else" *> parseManyStatements)
170parseReturn :: Bool -> I.IndentParser String () Statement
171parseReturn requireSemi = Return <$> (C.reserved "return" *> parseValue <* when requireSemi (void C.semi))
173parseStatement :: Bool -> I.IndentParser String () Statement
174parseStatement requireSemi = P.choice $ map P.try
175 [ parseVariableIntroduction requireSemi
176 , parseAssignment requireSemi
177 , parseWhile
178 , parseFor
179 , parseIfThenElse
180 , parseReturn requireSemi ]
182parseStringBinder :: I.IndentParser String () Binder
183parseStringBinder = StringBinder <$> C.stringLiteral
185parseBooleanBinder :: I.IndentParser String () Binder
186parseBooleanBinder = BooleanBinder <$> booleanLiteral
188parseNumberBinder :: I.IndentParser String () Binder
189parseNumberBinder = NumberBinder <$> C.naturalOrFloat
191parseVarBinder :: I.IndentParser String () Binder
192parseVarBinder = VarBinder <$> C.parseIdent
194parseNullaryBinder :: I.IndentParser String () Binder
195parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
197parseUnaryBinder :: I.IndentParser String () Binder
198parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> parseBinder
200parseObjectBinder :: I.IndentParser String () Binder
201parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep parseIdentifierAndBinder)
203parseArrayBinder :: I.IndentParser String () Binder
204parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep parseBinder) <*> P.optionMaybe (C.colon *> parseBinder)
206parseIdentifierAndBinder :: I.IndentParser String () (String, Binder)
207parseIdentifierAndBinder = do
208 name <- C.lexeme C.identifier
209 C.lexeme $ P.char '='
210 binder <- parseBinder
211 return (name, binder)
213parseBinder :: I.IndentParser String () Binder
214parseBinder = P.choice $ map P.try
215 [ parseStringBinder
216 , parseBooleanBinder
217 , parseNumberBinder
218 , parseVarBinder
219 , parseUnaryBinder
220 , parseNullaryBinder
221 , parseObjectBinder
222 , parseArrayBinder
223 , C.parens parseBinder ]
225parseAssignmentTarget :: I.IndentParser String () AssignmentTarget
226parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.parseIdent)
227 where
228 operators = [ [ Postfix $ AssignArrayIndex <$> C.squares parseValue
229 , Postfix $ AssignObjectProperty <$> (C.dot *> C.identifier) ] ]