git.iko.soy/elk
on 577fc17 help sign in
elk/compiler/Parse/Expression.hs
248 lines 8.1 kB history raw
1module Parse.Expression (def,term,typeAnnotation,expr) where
3import Control.Applicative ((<$>), (<*>))
4import Data.List (foldl')
5import Text.Parsec hiding (newline,spaces)
6import Text.Parsec.Indent
8import Parse.Binop
9import Parse.Helpers as Help
10import Parse.Literal
11import qualified Parse.Pattern as Pattern
12import qualified Parse.Type as Type
14import AST.Annotation as Annotation
15import AST.Expression.General
16import qualified AST.Expression.Source as Source
17import qualified AST.Literal as L
18import qualified AST.Pattern as P
19import qualified AST.Variable as Var
22-------- Basic Terms --------
24varTerm :: IParser Source.Expr'
25varTerm = toVar <$> var <?> "variable"
27toVar :: String -> Source.Expr'
28toVar v = case v of "True" -> Literal (L.Boolean True)
29 "False" -> Literal (L.Boolean False)
30 _ -> rawVar v
32accessor :: IParser Source.Expr'
33accessor = do
34 (start, lbl, end) <- located (try (string "." >> rLabel))
35 let loc e = Annotation.at start end e
36 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
38negative :: IParser Source.Expr'
39negative = do
40 (start, nTerm, end) <-
41 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
42 let loc e = Annotation.at start end e
43 return (Binop (Var.Raw "-") (loc $ Literal (L.IntNum 0)) nTerm)
46-------- Complex Terms --------
48listTerm :: IParser Source.Expr'
49listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)
50 where
51 range = do
52 lo <- expr
53 padded (string "..")
54 Range lo <$> expr
56 markdown' = do
57 pos <- getPosition
58 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
59 (rawText, exprs) <- Help.markdown (interpolation uid)
60 return (Markdown uid (filter (/='\r') rawText) exprs)
62 shader' = do
63 pos <- getPosition
64 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
65 (rawSrc, tipe) <- Help.shader
66 return $ GLShader uid (filter (/='\r') rawSrc) tipe
68 span uid index =
69 "<span id=\"md-" ++ uid ++ "-" ++ show index ++
70 "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
72 interpolation uid exprs = do
73 try (string "{{")
74 e <- padded expr
75 string "}}"
76 return (span uid (length exprs), exprs ++ [e])
78parensTerm :: IParser Source.Expr
79parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
80 where
81 opFn = do
82 (start, op, end) <- located anyOp
83 let loc = Annotation.at start end
84 return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
85 Binop (Var.Raw op) (loc (rawVar "x")) (loc (rawVar "y"))
87 tupleFn = do
88 let comma = char ',' <?> "comma ','"
89 (start, commas, end) <- located (comma >> many (whitespace >> comma))
90 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
91 loc = Annotation.at start end
92 return $ foldr (\x e -> loc $ Lambda x e)
93 (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
95 parened = do
96 (start, es, end) <- located (commaSep expr)
97 return $ case es of
98 [e] -> e
99 _ -> Annotation.at start end (tuple es)
101recordTerm :: IParser Source.Expr
102recordTerm = brackets $ choice [ misc, addLocation record ]
103 where
104 field = do
105 label <- rLabel
106 patterns <- spacePrefix Pattern.term
107 padded equals
108 body <- expr
109 return (label, makeFunction patterns body)
111 record = Record <$> commaSep field
113 change = do
114 lbl <- rLabel
115 padded (string "<-")
116 (,) lbl <$> expr
118 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
120 insert r = addLocation $ do
121 string "|" >> whitespace
122 Insert r <$> rLabel <*> (padded equals >> expr)
124 modify r =
125 addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
127 misc = try $ do
128 record <- addLocation (rawVar <$> rLabel)
129 opt <- padded (optionMaybe (remove record))
130 case opt of
131 Just e -> try (insert e) <|> return e
132 Nothing -> try (insert record) <|> try (modify record)
135term :: IParser Source.Expr
136term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
137 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
138 <?> "basic term (4, x, 'c', etc.)"
140-------- Applications --------
142appExpr :: IParser Source.Expr
143appExpr = do
144 t <- term
145 ts <- constrainedSpacePrefix term $ \str ->
146 if null str then notFollowedBy (char '-') else return ()
147 return $ case ts of
148 [] -> t
149 _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
151-------- Normal Expressions --------
153binaryExpr :: IParser Source.Expr
154binaryExpr = binops appExpr lastExpr anyOp
155 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
156 <|> lambdaExpr
158ifExpr :: IParser Source.Expr'
159ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
160 where
161 normal = do
162 bool <- expr
163 padded (reserved "then")
164 thenBranch <- expr
165 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
166 elseBranch <- expr
167 return $ MultiIf [(bool, thenBranch),
168 (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
169 multiIf = MultiIf <$> spaceSep1 iff
170 where iff = do string "|" ; whitespace
171 b <- expr ; padded arrow
172 (,) b <$> expr
174lambdaExpr :: IParser Source.Expr
175lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
176 whitespace
177 args <- spaceSep1 Pattern.term
178 padded arrow
179 body <- expr
180 return (makeFunction args body)
182defSet :: IParser [Source.Def]
183defSet = block (do d <- def ; whitespace ; return d)
185letExpr :: IParser Source.Expr'
186letExpr = do
187 reserved "let" ; whitespace
188 defs <- defSet
189 padded (reserved "in")
190 Let defs <$> expr
192caseExpr :: IParser Source.Expr'
193caseExpr = do
194 reserved "case"; e <- padded expr; reserved "of"; whitespace
195 Case e <$> (with <|> without)
196 where case_ = do p <- Pattern.expr
197 padded arrow
198 (,) p <$> expr
199 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
200 without = block (do c <- case_ ; whitespace ; return c)
202expr :: IParser Source.Expr
203expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
204 <|> lambdaExpr
205 <|> binaryExpr
206 <?> "an expression"
208defStart :: IParser [P.RawPattern]
209defStart =
210 choice [ do p1 <- try Pattern.term
211 infics p1 <|> func p1
212 , func =<< (P.Var <$> parens symOp)
213 , (:[]) <$> Pattern.expr
214 ] <?> "the definition of a variable (x = ...)"
215 where
216 func pattern =
217 case pattern of
218 P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
219 _ -> do try (lookAhead (whitespace >> string "="))
220 return [pattern]
222 infics p1 = do
223 o:p <- try (whitespace >> anyOp)
224 p2 <- (whitespace >> Pattern.term)
225 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
226 else [ P.Var (o:p), p1, p2 ]
228makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
229makeFunction args body@(A ann _) =
230 foldr (\arg body' -> A ann $ Lambda arg body') body args
232definition :: IParser Source.Def
233definition = withPos $ do
234 (name:args) <- defStart
235 padded equals
236 body <- expr
237 return . Source.Definition name $ makeFunction args body
239typeAnnotation :: IParser Source.Def
240typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr
241 where
242 start = do
243 v <- lowVar <|> parens symOp
244 padded hasType
245 return v
247def :: IParser Source.Def
248def = typeAnnotation <|> definition