git.iko.soy/rowtype-yoga/purescript-native
on ae6037f help sign in
rowtype-yoga/purescript-native/src/PureScript/Parser/Values.hs
212 lines 8.2 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
29booleanLiteral :: P.Parsec String () Bool
30booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
32parseNumericLiteral :: P.Parsec String () Value
33parseNumericLiteral = NumericLiteral <$> C.naturalOrFloat
35parseStringLiteral :: P.Parsec String () Value
36parseStringLiteral = StringLiteral <$> C.stringLiteral
38parseBooleanLiteral :: P.Parsec String () Value
39parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
41parseArrayLiteral :: P.Parsec String () Value
42parseArrayLiteral = ArrayLiteral <$> (C.squares $ C.commaSep parseValue)
44parseObjectLiteral :: P.Parsec String () Value
45parseObjectLiteral = ObjectLiteral <$> (C.braces $ C.commaSep parseIdentifierAndValue)
47parseIdentifierAndValue :: P.Parsec String () (String, Value)
48parseIdentifierAndValue = do
49 name <- C.lexeme C.identifier
50 C.colon
51 value <- parseValue
52 return (name, value)
54parseAbs :: P.Parsec String () Value
55parseAbs = do
56 C.lexeme $ P.char '\\'
57 args <- C.commaSep C.identifier
58 C.lexeme $ P.string "->"
59 value <- parseValue
60 return $ Abs args value
62parseApp :: P.Parsec String () Value
63parseApp = App <$> parseValue
64 <*> (C.parens $ C.commaSep parseValue)
66parseVar :: P.Parsec String () Value
67parseVar = Var <$> (C.identifier <|> C.properName)
69parseCase :: P.Parsec String () Value
70parseCase = Case <$> P.between (C.reserved "case") (C.reserved "of") parseValue
71 <*> C.braces (C.semiSep parseCaseAlternative)
73parseCaseAlternative :: P.Parsec String () (Binder, Value)
74parseCaseAlternative = (,) <$> (parseBinder <* C.lexeme (P.string "->")) <*> parseValue
76parseBlock :: P.Parsec String () Value
77parseBlock = Block <$> (C.braces $ P.many parseStatement)
79parseValueAtom :: P.Parsec String () Value
80parseValueAtom = P.choice $ map P.try
81 [ parseNumericLiteral
82 , parseStringLiteral
83 , parseBooleanLiteral
84 , parseArrayLiteral
85 , parseObjectLiteral
86 , parseAbs
87 , parseVar
88 , parseBlock
89 , parseCase
90 , C.parens parseValue ]
92parseValue :: P.Parsec String () Value
93parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.lexeme funArgs) App
94 where
95 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue
96 funArgs = C.parens $ C.commaSep parseValue
97 parseTypeAnnotation = C.lexeme (P.string "::") *> parseType
98 operators = [ [ Postfix $ Accessor <$> (C.dot *> C.identifier)
99 , Postfix $ Indexer <$> C.squares parseValue ]
100 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)
101 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)
102 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]
103 , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight
104 , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight
105 , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]
106 , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight
107 , Infix (C.lexeme (P.char '+') >> return (Binary Add)) AssocRight
108 , Infix (C.lexeme (P.char '-') >> return (Binary Subtract)) AssocRight ]
109 , [ Infix (C.lexeme (P.string "<<") >> return (Binary ShiftLeft)) AssocRight
110 , Infix (C.lexeme (P.try (P.string ">>>")) >> return (Binary ZeroFillShiftRight)) AssocRight
111 , Infix (C.lexeme (P.string ">>") >> return (Binary ShiftRight)) AssocRight ]
112 , [ Infix (C.lexeme (P.string "==") >> return (Binary EqualTo)) AssocRight
113 , Infix (C.lexeme (P.try (P.string "!=")) >> return (Binary NotEqualTo)) AssocRight ]
114 , [ Infix (C.lexeme (P.try (P.char '&' <* P.notFollowedBy (P.char '&'))) >> return (Binary BitwiseAnd)) AssocRight ]
115 , [ Infix (C.lexeme (P.char '^') >> return (Binary BitwiseXor)) AssocRight ]
116 , [ Infix (C.lexeme (P.try (P.char '|' <* P.notFollowedBy (P.char '|'))) >> return (Binary BitwiseOr)) AssocRight ]
117 , [ Infix (C.lexeme (P.string "&&") >> return (Binary And)) AssocRight ]
118 , [ Infix (C.lexeme (P.string "||") >> return (Binary Or)) AssocRight ]
119 ]
121parseVariableIntroduction :: P.Parsec String () Statement
122parseVariableIntroduction = do
123 C.reserved "var"
124 name <- C.identifier
125 C.lexeme $ P.char '='
126 value <- parseValue
127 C.semi
128 return $ VariableIntroduction name value
130parseAssignment :: P.Parsec String () (Statement)
131parseAssignment = do
132 tgt <- C.identifier
133 C.lexeme $ P.char '='
134 value <- parseValue
135 C.semi
136 return $ Assignment tgt value
138parseManyStatements :: P.Parsec String () [Statement]
139parseManyStatements = C.braces $ P.many parseStatement
141parseWhile :: P.Parsec String () Statement
142parseWhile = While <$> (C.reserved "while" *> C.parens parseValue)
143 <*> parseManyStatements
145parseFor :: P.Parsec String () Statement
146parseFor = For <$> (C.reserved "for" *> C.parens forIntro)
147 <*> parseManyStatements
148 where
149 forIntro = (,,) <$> parseStatement
150 <*> (C.semi *> parseValue)
151 <*> (C.semi *> parseStatement)
153parseIfThenElse :: P.Parsec String () Statement
154parseIfThenElse = IfThenElse
155 <$> (C.reserved "if" *> C.parens parseValue)
156 <*> parseManyStatements
157 <*> P.optionMaybe (C.reserved "else" *> parseManyStatements)
159parseReturn :: P.Parsec String () Statement
160parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.semi)
162parseStatement :: P.Parsec String () Statement
163parseStatement = P.choice $ map P.try
164 [ parseVariableIntroduction
165 , parseAssignment
166 , parseWhile
167 , parseFor
168 , parseIfThenElse
169 , parseReturn ]
171parseStringBinder :: P.Parsec String () Binder
172parseStringBinder = StringBinder <$> C.stringLiteral
174parseBooleanBinder :: P.Parsec String () Binder
175parseBooleanBinder = BooleanBinder <$> booleanLiteral
177parseNumberBinder :: P.Parsec String () Binder
178parseNumberBinder = NumberBinder <$> C.naturalOrFloat
180parseVarBinder :: P.Parsec String () Binder
181parseVarBinder = VarBinder <$> C.lexeme C.identifier
183parseNullaryBinder :: P.Parsec String () Binder
184parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
186parseUnaryBinder :: P.Parsec String () Binder
187parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> parseBinder
189parseObjectBinder :: P.Parsec String () Binder
190parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep parseIdentifierAndBinder)
192parseArrayBinder :: P.Parsec String () Binder
193parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep parseBinder) <*> P.optionMaybe (C.colon *> parseBinder)
195parseIdentifierAndBinder :: P.Parsec String () (String, Binder)
196parseIdentifierAndBinder = do
197 name <- C.lexeme C.identifier
198 C.lexeme $ P.char '='
199 binder <- parseBinder
200 return (name, binder)
202parseBinder :: P.Parsec String () Binder
203parseBinder = P.choice $ map P.try
204 [ parseStringBinder
205 , parseBooleanBinder
206 , parseNumberBinder
207 , parseVarBinder
208 , parseUnaryBinder
209 , parseNullaryBinder
210 , parseObjectBinder
211 , parseArrayBinder
212 , C.parens parseBinder ]