git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Parse/Expression.hs
238 lines 7.8 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.Helpers
9import qualified Parse.Pattern as Pattern
10import qualified Parse.Type as Type
11import Parse.Binop
12import Parse.Literal
14import SourceSyntax.Location as Location
15import SourceSyntax.Pattern hiding (tuple,list)
16import qualified SourceSyntax.Literal as Literal
17import SourceSyntax.Expression
20-------- Basic Terms --------
22varTerm :: IParser ParseExpr
23varTerm = toVar <$> var <?> "variable"
25toVar :: String -> ParseExpr
26toVar v = case v of "True" -> Literal (Literal.Boolean True)
27 "False" -> Literal (Literal.Boolean False)
28 _ -> Var v
30accessor :: IParser ParseExpr
31accessor = do
32 (start, lbl, end) <- located (try (string "." >> rLabel))
33 let loc e = Location.at start end e
34 return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
36negative :: IParser ParseExpr
37negative = do
38 (start, nTerm, end) <-
39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
40 let loc e = Location.at start end e
41 return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
44-------- Complex Terms --------
46listTerm :: IParser ParseExpr
47listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
48 where
49 range = do
50 lo <- expr
51 padded (string "..")
52 Range lo <$> expr
54 markdown' = do
55 pos <- getPosition
56 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
57 (rawText, exprs) <- markdown (interpolation uid)
58 return (Markdown uid (filter (/='\r') rawText) exprs)
60 span uid index =
61 "<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
63 interpolation uid md exprs = do
64 try (string "{{")
65 e <- padded expr
66 string "}}"
67 return (md ++ span uid (length exprs), exprs ++ [e])
69parensTerm :: IParser LParseExpr
70parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
71 where
72 opFn = do
73 (start, op, end) <- located anyOp
74 let loc = Location.at start end
75 return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
76 Binop op (loc $ Var "x") (loc $ Var "y")
78 tupleFn = do
79 let comma = char ',' <?> "comma ','"
80 (start, commas, end) <- located (comma >> many (whitespace >> comma))
81 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
82 loc = Location.at start end
83 return $ foldr (\x e -> loc $ Lambda x e)
84 (loc . tuple $ map (loc . Var) vars) (map PVar vars)
86 parened = do
87 (start, es, end) <- located (commaSep expr)
88 return $ case es of
89 [e] -> e
90 _ -> Location.at start end (tuple es)
92recordTerm :: IParser LParseExpr
93recordTerm = brackets $ choice [ misc, addLocation record ]
94 where field = do
95 label <- rLabel
96 patterns <- spacePrefix Pattern.term
97 padded equals
98 body <- expr
99 return (label, makeFunction patterns body)
101 record = Record <$> commaSep field
103 change = do
104 lbl <- rLabel
105 padded (string "<-")
106 (,) lbl <$> expr
108 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
110 insert r = addLocation $ do
111 string "|" >> whitespace
112 Insert r <$> rLabel <*> (padded equals >> expr)
114 modify r = addLocation
115 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
117 misc = try $ do
118 record <- addLocation (Var <$> rLabel)
119 opt <- padded (optionMaybe (remove record))
120 case opt of
121 Just e -> try (insert e) <|> return e
122 Nothing -> try (insert record) <|> try (modify record)
125term :: IParser LParseExpr
126term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
127 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
128 <?> "basic term (4, x, 'c', etc.)"
130-------- Applications --------
132appExpr :: IParser LParseExpr
133appExpr = do
134 t <- term
135 ts <- constrainedSpacePrefix term $ \str ->
136 if null str then notFollowedBy (char '-') else return ()
137 return $ case ts of
138 [] -> t
139 _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
141-------- Normal Expressions --------
143binaryExpr :: IParser LParseExpr
144binaryExpr = binops appExpr lastExpr anyOp
145 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
146 <|> lambdaExpr
148ifExpr :: IParser ParseExpr
149ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
150 where
151 normal = do
152 bool <- expr
153 padded (reserved "then")
154 thenBranch <- expr
155 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
156 elseBranch <- expr
157 return $ MultiIf [(bool, thenBranch),
158 (Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
159 multiIf = MultiIf <$> spaceSep1 iff
160 where iff = do string "|" ; whitespace
161 b <- expr ; padded arrow
162 (,) b <$> expr
164lambdaExpr :: IParser LParseExpr
165lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
166 whitespace
167 args <- spaceSep1 Pattern.term
168 padded arrow
169 body <- expr
170 return (makeFunction args body)
172defSet :: IParser [ParseDef]
173defSet = block (do d <- def ; whitespace ; return d)
175letExpr :: IParser ParseExpr
176letExpr = do
177 reserved "let" ; whitespace
178 defs <- defSet
179 padded (reserved "in")
180 Let defs <$> expr
182caseExpr :: IParser ParseExpr
183caseExpr = do
184 reserved "case"; e <- padded expr; reserved "of"; whitespace
185 Case e <$> (with <|> without)
186 where case_ = do p <- Pattern.expr
187 padded arrow
188 (,) p <$> expr
189 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
190 without = block (do c <- case_ ; whitespace ; return c)
192expr :: IParser LParseExpr
193expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
194 <|> lambdaExpr
195 <|> binaryExpr
196 <?> "an expression"
198defStart :: IParser [Pattern]
199defStart =
200 choice [ do p1 <- try Pattern.term
201 infics p1 <|> func p1
202 , func =<< (PVar <$> parens symOp)
203 , (:[]) <$> Pattern.expr
204 ] <?> "the definition of a variable (x = ...)"
205 where
206 func pattern =
207 case pattern of
208 PVar _ -> (pattern:) <$> spacePrefix Pattern.term
209 _ -> do try (lookAhead (whitespace >> string "="))
210 return [pattern]
212 infics p1 = do
213 o:p <- try (whitespace >> anyOp)
214 p2 <- (whitespace >> Pattern.term)
215 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
216 else [ PVar (o:p), p1, p2 ]
218makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
219makeFunction args body@(L s _) =
220 foldr (\arg body' -> L s $ Lambda arg body') body args
222definition :: IParser ParseDef
223definition = withPos $ do
224 (name:args) <- defStart
225 padded equals
226 body <- expr
227 return . Def name $ makeFunction args body
229typeAnnotation :: IParser ParseDef
230typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
231 where
232 start = do
233 v <- lowVar <|> parens symOp
234 padded hasType
235 return v
237def :: IParser ParseDef
238def = typeAnnotation <|> definition