git.iko.soy/rowtype-yoga/purescript-native
on 92622fd help sign in
rowtype-yoga/purescript-native/src/PureScript/Parser/Values.hs
289 lines 14 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 PureScript.Names
22import PureScript.Declarations
23import PureScript.Parser.State
24import Data.Function (on)
25import Data.List
26import Data.Functor.Identity
27import qualified Data.Map as M
28import qualified PureScript.Parser.Common as C
29import Control.Applicative
30import qualified Text.Parsec as P
31import Text.Parsec.Expr
32import Control.Monad
33import Control.Arrow (Arrow(..))
34import PureScript.Parser.Types
35import PureScript.Types
37booleanLiteral :: P.Parsec String ParseState Bool
38booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
40parseNumericLiteral :: P.Parsec String ParseState Value
41parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
43parseStringLiteral :: P.Parsec String ParseState Value
44parseStringLiteral = StringLiteral <$> C.stringLiteral
46parseBooleanLiteral :: P.Parsec String ParseState Value
47parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
49parseArrayLiteral :: P.Parsec String ParseState Value
50parseArrayLiteral = ArrayLiteral <$> (C.squares $ parseValue `P.sepBy` (C.indented *> C.comma))
52parseObjectLiteral :: P.Parsec String ParseState Value
53parseObjectLiteral = ObjectLiteral <$> (C.braces $ parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))
55parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
56parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
57 <*> (C.indented *> parseValue)
59parseAbs :: P.Parsec String ParseState Value
60parseAbs = do
61 C.lexeme $ P.char '\\'
62 args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)
63 C.lexeme $ C.indented *> P.string "->"
64 value <- parseValue
65 return $ Abs args value
67parseApp :: P.Parsec String ParseState Value
68parseApp = App <$> parseValue
69 <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
71parseVar :: P.Parsec String ParseState Value
72parseVar = Var <$> C.parseIdent
74parseConstructor :: P.Parsec String ParseState Value
75parseConstructor = Constructor <$> C.properName
77parseCase :: P.Parsec String ParseState Value
78parseCase = Case <$> (P.between (C.reserved "case") (C.indented *> C.reserved "of") parseValue)
79 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
81parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)
82parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))
83 <*> parseValue
84 P.<?> "case alternative"
86parseIfThenElse :: P.Parsec String ParseState Value
87parseIfThenElse = IfThenElse <$> (C.reserved "if" *> C.indented *> parseValue)
88 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
89 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
91parseBlock :: P.Parsec String ParseState Value
92parseBlock = Block <$> (C.reserved "do" *> parseManyStatements)
94parseManyStatements :: P.Parsec String ParseState [Statement]
95parseManyStatements = C.indented *> (C.mark $ P.many $ C.same *> C.mark parseStatement) P.<?> "block"
97parseValueAtom :: P.Parsec String ParseState Value
98parseValueAtom = C.indented *> P.choice (map P.try
99 [ parseNumericLiteral
100 , parseStringLiteral
101 , parseBooleanLiteral
102 , parseArrayLiteral
103 , parseObjectLiteral
104 , parseAbs
105 , parseVar
106 , parseConstructor
107 , parseBlock
108 , parseCase
109 , parseIfThenElse
110 , C.parens parseValue ])
112parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
113parsePropertyUpdate = do
114 name <- C.lexeme C.identifier
115 C.lexeme $ C.indented *> P.char '='
116 value <- C.indented *> parseValue
117 return (name, value)
119parseValue :: P.Parsec String ParseState Value
120parseValue = do
121 customOps <- fixities <$> P.getState
122 (buildExpressionParser (operators customOps)
123 . C.buildPostfixParser postfixTable2
124 $ indexersAndAccessors) P.<?> "expression"
125 where
126 indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom
127 postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
128 , Indexer <$> (C.indented *> C.squares parseValue)
129 , flip ObjectUpdate <$> (C.indented *> C.braces ((C.indented *> parsePropertyUpdate) `P.sepBy1` (C.indented *> C.comma))) ]
130 postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])
131 , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
132 , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]
133 operators user =
134 [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
135 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
136 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
137 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
138 ] ++ customOperatorTable user ++
139 [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
140 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
141 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
142 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight
143 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">") >> return (Binary GreaterThan)) AssocRight ]
144 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "*") >> return (Binary Multiply)) AssocRight
145 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "/") >> return (Binary Divide)) AssocRight
146 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "%") >> return (Binary Modulus)) AssocRight ]
147 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "++") >> return (Binary Concat)) AssocRight
148 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return (Binary Add)) AssocRight
149 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Binary Subtract)) AssocRight ]
150 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<<") >> return (Binary ShiftLeft)) AssocRight
151 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>>") >> return (Binary ZeroFillShiftRight)) AssocRight
152 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>") >> return (Binary ShiftRight)) AssocRight ]
153 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "==") >> return (Binary EqualTo)) AssocRight
154 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!=") >> return (Binary NotEqualTo)) AssocRight ]
155 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&") >> return (Binary BitwiseAnd)) AssocRight ]
156 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "^") >> return (Binary BitwiseXor)) AssocRight ]
157 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "|") >> return (Binary BitwiseOr)) AssocRight ]
158 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&&") >> return (Binary And)) AssocRight ]
159 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]
160 ]
162customOperatorTable :: M.Map String Fixity -> OperatorTable String ParseState Identity Value
163customOperatorTable fixities =
164 let
165 ops = map (\(name, Fixity a p) -> (name, (a, p))) . M.toList $ fixities
166 sorted = sortBy (compare `on` (snd . snd)) ops
167 levels = groupBy ((==) `on` (snd . snd)) sorted
168 in
169 flip map levels (map (\(name, (a, _)) -> flip Infix (toAssoc a) $ do
170 C.lexeme $ P.try $ do
171 C.indented
172 C.reservedOp name P.<?> "operator"
173 return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2]))
175toAssoc :: Associativity -> Assoc
176toAssoc Infixl = AssocLeft
177toAssoc Infixr = AssocRight
179parseVariableIntroduction :: P.Parsec String ParseState Statement
180parseVariableIntroduction = do
181 C.reserved "var"
182 name <- C.indented *> C.parseIdent
183 C.lexeme $ C.indented *> P.char '='
184 value <- parseValue
185 return $ VariableIntroduction name value
187parseAssignment :: P.Parsec String ParseState Statement
188parseAssignment = do
189 tgt <- C.parseIdent
190 C.lexeme $ C.indented *> P.char '='
191 value <- parseValue
192 return $ Assignment tgt value
194parseWhile :: P.Parsec String ParseState Statement
195parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
196 <*> parseManyStatements
198parseFor :: P.Parsec String ParseState Statement
199parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
200 <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
201 <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
202 <*> parseManyStatements
204parseForEach :: P.Parsec String ParseState Statement
205parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
206 <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
207 <*> parseManyStatements
209parseIf :: P.Parsec String ParseState Statement
210parseIf = If <$> parseIfStatement
212parseIfStatement :: P.Parsec String ParseState IfStatement
213parseIfStatement =
214 IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
215 <*> parseManyStatements
216 <*> P.optionMaybe (C.same *> parseElseStatement)
218parseElseStatement :: P.Parsec String ParseState ElseStatement
219parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
220 <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
222parseReturn :: P.Parsec String ParseState Statement
223parseReturn = Return <$> (C.reserved "return" *> parseValue)
225parseStatement :: P.Parsec String ParseState Statement
226parseStatement = P.choice (map P.try
227 [ parseVariableIntroduction
228 , parseAssignment
229 , parseWhile
230 , parseFor
231 , parseForEach
232 , parseIf
233 , parseReturn ]) P.<?> "statement"
235parseStringBinder :: P.Parsec String ParseState Binder
236parseStringBinder = StringBinder <$> C.stringLiteral
238parseBooleanBinder :: P.Parsec String ParseState Binder
239parseBooleanBinder = BooleanBinder <$> booleanLiteral
241parseNumberBinder :: P.Parsec String ParseState Binder
242parseNumberBinder = NumberBinder <$> C.integerOrFloat
244parseVarBinder :: P.Parsec String ParseState Binder
245parseVarBinder = VarBinder <$> C.parseIdent
247parseNullaryBinder :: P.Parsec String ParseState Binder
248parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
250parseUnaryBinder :: P.Parsec String ParseState Binder
251parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)
253parseObjectBinder :: P.Parsec String ParseState Binder
254parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
256parseArrayBinder :: P.Parsec String ParseState Binder
257parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma))
258 <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)
260parseNamedBinder :: P.Parsec String ParseState Binder
261parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
262 <*> (C.indented *> parseBinder)
264parseNullBinder :: P.Parsec String ParseState Binder
265parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
267parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
268parseIdentifierAndBinder = do
269 name <- C.lexeme C.identifier
270 C.lexeme $ C.indented *> P.char '='
271 binder <- C.indented *> parseBinder
272 return (name, binder)
274parseBinder :: P.Parsec String ParseState Binder
275parseBinder = P.choice (map P.try
276 [ parseNullBinder
277 , parseStringBinder
278 , parseBooleanBinder
279 , parseNumberBinder
280 , parseNamedBinder
281 , parseVarBinder
282 , parseUnaryBinder
283 , parseNullaryBinder
284 , parseObjectBinder
285 , parseArrayBinder
286 , C.parens parseBinder ]) P.<?> "binder"
288parseGuardedBinder :: P.Parsec String ParseState Binder
289parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))