git.iko.soy/elk
on d87affe help sign in
elk/src/Parse/Expression.hs
245 lines 8.0 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 = toVar <$> var <?> "variable"
28toVar :: String -> Source.Expr'
29toVar v =
30 case v of
31 "True" -> E.Literal (L.Boolean True)
32 "False" -> E.Literal (L.Boolean False)
33 _ -> E.rawVar v
35accessor :: IParser Source.Expr'
36accessor = do
37 (start, lbl, end) <- located (try (string "." >> rLabel))
38 let loc e = Annotation.at start end e
39 return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl))
41negative :: IParser Source.Expr'
42negative = do
43 (start, nTerm, end) <-
44 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
45 let loc e = Annotation.at start end e
46 return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm)
49-------- Complex Terms --------
51listTerm :: IParser Source.Expr'
52listTerm = markdown' <|> shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
53 where
54 range = do
55 lo <- expr
56 padded (string "..")
57 E.Range lo <$> expr
59 markdown' = do
60 pos <- getPosition
61 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
62 rawText <- Help.markdown
63 return (E.Markdown uid (filter (/='\r') rawText))
65 shader' = do
66 pos <- getPosition
67 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
68 (rawSrc, tipe) <- Help.shader
69 return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
72parensTerm :: IParser Source.Expr
73parensTerm = 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 = brackets $ choice [ misc, addLocation record ]
97 where
98 field = do
99 label <- rLabel
100 patterns <- spacePrefix Pattern.term
101 padded equals
102 body <- expr
103 return (label, makeFunction patterns body)
105 record = E.Record <$> commaSep field
107 change = do
108 lbl <- rLabel
109 padded (string "<-")
110 (,) lbl <$> expr
112 remove r = addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel)
114 insert r = addLocation $ do
115 string "|" >> whitespace
116 E.Insert r <$> rLabel <*> (padded equals >> expr)
118 modify r =
119 addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change)
121 misc = try $ do
122 record <- addLocation (E.rawVar <$> rLabel)
123 opt <- padded (optionMaybe (remove record))
124 case opt of
125 Just e -> try (insert e) <|> return e
126 Nothing -> try (insert record) <|> try (modify record)
129term :: IParser Source.Expr
130term = addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
131 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
132 <?> "basic term (4, x, 'c', etc.)"
134-------- Applications --------
136appExpr :: IParser Source.Expr
137appExpr = do
138 t <- term
139 ts <- constrainedSpacePrefix term $ \str ->
140 if null str then notFollowedBy (char '-') else return ()
141 return $ case ts of
142 [] -> t
143 _ -> List.foldl' (\f x -> Annotation.merge f x $ E.App f x) t ts
145-------- Normal Expressions --------
147binaryExpr :: IParser Source.Expr
148binaryExpr = Binop.binops appExpr lastExpr anyOp
149 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
150 <|> lambdaExpr
152ifExpr :: IParser Source.Expr'
153ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
154 where
155 normal = do
156 bool <- expr
157 padded (reserved "then")
158 thenBranch <- expr
159 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
160 elseBranch <- expr
161 return $ E.MultiIf
162 [ (bool, thenBranch)
163 , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
164 ]
166 multiIf = E.MultiIf <$> spaceSep1 iff
167 where iff = do string "|" ; whitespace
168 b <- expr ; padded arrow
169 (,) b <$> expr
171lambdaExpr :: IParser Source.Expr
172lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
173 whitespace
174 args <- spaceSep1 Pattern.term
175 padded arrow
176 body <- expr
177 return (makeFunction args body)
179defSet :: IParser [Source.Def]
180defSet = block (do d <- def ; whitespace ; return d)
182letExpr :: IParser Source.Expr'
183letExpr = do
184 reserved "let" ; whitespace
185 defs <- defSet
186 padded (reserved "in")
187 E.Let defs <$> expr
189caseExpr :: IParser Source.Expr'
190caseExpr = do
191 reserved "case"; e <- padded expr; reserved "of"; whitespace
192 E.Case e <$> (with <|> without)
193 where case_ = do p <- Pattern.expr
194 padded arrow
195 (,) p <$> expr
196 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
197 without = block (do c <- case_ ; whitespace ; return c)
199expr :: IParser Source.Expr
200expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
201 <|> lambdaExpr
202 <|> binaryExpr
203 <?> "an expression"
205defStart :: IParser [P.RawPattern]
206defStart =
207 choice [ do p1 <- try Pattern.term
208 infics p1 <|> func p1
209 , func =<< (P.Var <$> parens symOp)
210 , (:[]) <$> Pattern.expr
211 ] <?> "the definition of a variable (x = ...)"
212 where
213 func pattern =
214 case pattern of
215 P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
216 _ -> do try (lookAhead (whitespace >> string "="))
217 return [pattern]
219 infics p1 = do
220 o:p <- try (whitespace >> anyOp)
221 p2 <- (whitespace >> Pattern.term)
222 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
223 else [ P.Var (o:p), p1, p2 ]
225makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
226makeFunction args body@(Annotation.A ann _) =
227 foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args
229definition :: IParser Source.Def
230definition = withPos $ do
231 (name:args) <- defStart
232 padded equals
233 body <- expr
234 return . Source.Definition name $ makeFunction args body
236typeAnnotation :: IParser Source.Def
237typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr
238 where
239 start = do
240 v <- lowVar <|> parens symOp
241 padded hasType
242 return v
244def :: IParser Source.Def
245def = typeAnnotation <|> definition