git.iko.soy/elk
on 501c607 help sign in
elk/src/Parse/Expression.hs
291 lines 7.9 kB history raw
1module Parse.Expression (def,term,typeAnnotation,expr) where
3import Control.Applicative ((<$>), (<*>))
4import qualified Data.List as List
5import Text.Parsec hiding (newline, spaces)
6import Text.Parsec.Indent (block, withPos)
8import qualified Parse.Binop as Binop
9import Parse.Helpers
10import qualified Parse.Helpers as Help
11import qualified Parse.Literal as Literal
12import qualified Parse.Pattern as Pattern
13import qualified Parse.Type as Type
15import qualified AST.Annotation as Annotation
16import qualified AST.Expression.General as E
17import qualified AST.Expression.Source as Source
18import qualified AST.Literal as L
19import qualified AST.Pattern as P
20import qualified AST.Variable as Var
23-------- Basic Terms --------
25varTerm :: IParser Source.Expr'
26varTerm =
27 toVar <$> var <?> "variable"
30toVar :: String -> Source.Expr'
31toVar v =
32 case v of
33 "True" -> E.Literal (L.Boolean True)
34 "False" -> E.Literal (L.Boolean False)
35 _ -> E.rawVar v
38accessor :: IParser Source.Expr'
39accessor =
40 do (start, lbl, end) <- located (try (string "." >> rLabel))
41 let loc e = Annotation.at start end e
42 return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl))
45negative :: IParser Source.Expr'
46negative =
47 do (start, nTerm, end) <-
48 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
49 let loc e = Annotation.at start end e
50 return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm)
53-------- Complex Terms --------
55listTerm :: IParser Source.Expr'
56listTerm =
57 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
58 where
59 range = do
60 lo <- expr
61 padded (string "..")
62 E.Range lo <$> expr
64 shader' = do
65 pos <- getPosition
66 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
67 (rawSrc, tipe) <- Help.shader
68 return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
71parensTerm :: IParser Source.Expr
72parensTerm =
73 try (parens opFn) <|> parens (tupleFn <|> parened)
74 where
75 opFn = do
76 (start, op, end) <- located anyOp
77 let loc = Annotation.at start end
78 return . loc . E.Lambda (P.Var "x") . loc . E.Lambda (P.Var "y") . loc $
79 E.Binop (Var.Raw op) (loc (E.rawVar "x")) (loc (E.rawVar "y"))
81 tupleFn = do
82 let comma = char ',' <?> "comma ','"
83 (start, commas, end) <- located (comma >> many (whitespace >> comma))
84 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
85 loc = Annotation.at start end
86 return $ foldr (\x e -> loc $ E.Lambda x e)
87 (loc . E.tuple $ map (loc . E.rawVar) vars) (map P.Var vars)
89 parened = do
90 (start, es, end) <- located (commaSep expr)
91 return $ case es of
92 [e] -> e
93 _ -> Annotation.at start end (E.tuple es)
95recordTerm :: IParser Source.Expr
96recordTerm =
97 brackets $ choice [ misc, addLocation record ]
98 where
99 field =
100 do label <- rLabel
101 patterns <- spacePrefix Pattern.term
102 padded equals
103 body <- expr
104 return (label, makeFunction patterns body)
106 record =
107 E.Record <$> commaSep field
109 change =
110 do lbl <- rLabel
111 padded (string "<-")
112 (,) lbl <$> expr
114 remove r =
115 addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel)
117 insert r =
118 addLocation $
119 do string "|" >> whitespace
120 E.Insert r <$> rLabel <*> (padded equals >> expr)
122 modify r =
123 addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change)
125 misc =
126 try $ do
127 record <- addLocation (E.rawVar <$> rLabel)
128 opt <- padded (optionMaybe (remove record))
129 case opt of
130 Just e -> try (insert e) <|> return e
131 Nothing -> try (insert record) <|> try (modify record)
134term :: IParser Source.Expr
135term = addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
136 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
137 <?> "basic term (4, x, 'c', etc.)"
140-------- Applications --------
142appExpr :: IParser Source.Expr
143appExpr =
144 do t <- term
145 ts <- constrainedSpacePrefix term $ \str ->
146 if null str then notFollowedBy (char '-') else return ()
147 return $
148 case ts of
149 [] -> t
150 _ -> List.foldl' (\f x -> Annotation.merge f x $ E.App f x) t ts
153-------- Normal Expressions --------
155binaryExpr :: IParser Source.Expr
156binaryExpr =
157 Binop.binops appExpr lastExpr anyOp
158 where
159 lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
160 <|> lambdaExpr
163ifExpr :: IParser Source.Expr'
164ifExpr =
165 do try (reserved "if")
166 whitespace
167 normal <|> multiIf
168 where
169 normal =
170 do bool <- expr
171 padded (reserved "then")
172 thenBranch <- expr
173 whitespace <?> "an 'else' branch"
174 reserved "else" <?> "an 'else' branch"
175 whitespace
176 elseBranch <- expr
177 return $ E.MultiIf
178 [ (bool, thenBranch)
179 , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
180 ]
182 multiIf =
183 E.MultiIf <$> spaceSep1 iff
184 where
185 iff =
186 do string "|" ; whitespace
187 b <- expr ; padded arrow
188 (,) b <$> expr
191lambdaExpr :: IParser Source.Expr
192lambdaExpr =
193 do char '\\' <|> char '\x03BB' <?> "anonymous function"
194 whitespace
195 args <- spaceSep1 Pattern.term
196 padded arrow
197 body <- expr
198 return (makeFunction args body)
201defSet :: IParser [Source.Def]
202defSet =
203 block $
204 do d <- def
205 whitespace
206 return d
209letExpr :: IParser Source.Expr'
210letExpr =
211 do try (reserved "let")
212 whitespace
213 defs <- defSet
214 padded (reserved "in")
215 E.Let defs <$> expr
218caseExpr :: IParser Source.Expr'
219caseExpr =
220 do try (reserved "case")
221 e <- padded expr
222 reserved "of"
223 whitespace
224 E.Case e <$> (with <|> without)
225 where
226 case_ =
227 do p <- Pattern.expr
228 padded arrow
229 (,) p <$> expr
231 with =
232 brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
234 without =
235 block (do c <- case_ ; whitespace ; return c)
238expr :: IParser Source.Expr
239expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
240 <|> lambdaExpr
241 <|> binaryExpr
242 <?> "an expression"
245defStart :: IParser [P.RawPattern]
246defStart =
247 choice [ do p1 <- try Pattern.term
248 infics p1 <|> func p1
249 , func =<< (P.Var <$> parens symOp)
250 , (:[]) <$> Pattern.expr
251 ] <?> "the definition of a variable (x = ...)"
252 where
253 func pattern =
254 case pattern of
255 P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
256 _ -> do try (lookAhead (whitespace >> string "="))
257 return [pattern]
259 infics p1 = do
260 o:p <- try (whitespace >> anyOp)
261 p2 <- (whitespace >> Pattern.term)
262 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
263 else [ P.Var (o:p), p1, p2 ]
265makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
266makeFunction args body@(Annotation.A ann _) =
267 foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args
270definition :: IParser Source.Def
271definition =
272 withPos $
273 do (name:args) <- defStart
274 padded equals
275 body <- expr
276 return . Source.Definition name $ makeFunction args body
279typeAnnotation :: IParser Source.Def
280typeAnnotation =
281 Source.TypeAnnotation <$> try start <*> Type.expr
282 where
283 start =
284 do v <- lowVar <|> parens symOp
285 padded hasType
286 return v
289def :: IParser Source.Def
290def =
291 typeAnnotation <|> definition