git.iko.soy/elk
on 4bec310 help sign in
elk/compiler/Parse/Expression.hs
239 lines 7.7 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
10import Parse.Literal
11import qualified Parse.Pattern as Pattern
12import qualified Parse.Type as Type
14import SourceSyntax.Annotation as Annotation
15import qualified SourceSyntax.Pattern as P
16import qualified SourceSyntax.Literal as L
17import SourceSyntax.Expression
20-------- Basic Terms --------
22varTerm :: IParser ParseExpr'
23varTerm = toVar <$> var <?> "variable"
25toVar :: String -> ParseExpr'
26toVar v = case v of "True" -> Literal (L.Boolean True)
27 "False" -> Literal (L.Boolean False)
28 _ -> rawVar v
30accessor :: IParser ParseExpr'
31accessor = do
32 (start, lbl, end) <- located (try (string "." >> rLabel))
33 let loc e = Annotation.at start end e
34 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
36negative :: IParser ParseExpr'
37negative = do
38 (start, nTerm, end) <-
39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
40 let loc e = Annotation.at start end e
41 return (Binop "-" (loc $ Literal (L.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 exprs = do
64 try (string "{{")
65 e <- padded expr
66 string "}}"
67 return (span uid (length exprs), exprs ++ [e])
69parensTerm :: IParser ParseExpr
70parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
71 where
72 opFn = do
73 (start, op, end) <- located anyOp
74 let loc = Annotation.at start end
75 return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
76 Binop op (loc $ rawVar "x") (loc $ rawVar "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 = Annotation.at start end
83 return $ foldr (\x e -> loc $ Lambda x e)
84 (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
86 parened = do
87 (start, es, end) <- located (commaSep expr)
88 return $ case es of
89 [e] -> e
90 _ -> Annotation.at start end (tuple es)
92recordTerm :: IParser ParseExpr
93recordTerm = brackets $ choice [ misc, addLocation record ]
94 where
95 field = do
96 label <- rLabel
97 patterns <- spacePrefix Pattern.term
98 padded equals
99 body <- expr
100 return (label, makeFunction patterns body)
102 record = Record <$> commaSep field
104 change = do
105 lbl <- rLabel
106 padded (string "<-")
107 (,) lbl <$> expr
109 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
111 insert r = addLocation $ do
112 string "|" >> whitespace
113 Insert r <$> rLabel <*> (padded equals >> expr)
115 modify r =
116 addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
118 misc = try $ do
119 record <- addLocation (rawVar <$> rLabel)
120 opt <- padded (optionMaybe (remove record))
121 case opt of
122 Just e -> try (insert e) <|> return e
123 Nothing -> try (insert record) <|> try (modify record)
126term :: IParser ParseExpr
127term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
128 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
129 <?> "basic term (4, x, 'c', etc.)"
131-------- Applications --------
133appExpr :: IParser ParseExpr
134appExpr = do
135 t <- term
136 ts <- constrainedSpacePrefix term $ \str ->
137 if null str then notFollowedBy (char '-') else return ()
138 return $ case ts of
139 [] -> t
140 _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
142-------- Normal Expressions --------
144binaryExpr :: IParser ParseExpr
145binaryExpr = binops appExpr lastExpr anyOp
146 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
147 <|> lambdaExpr
149ifExpr :: IParser ParseExpr'
150ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
151 where
152 normal = do
153 bool <- expr
154 padded (reserved "then")
155 thenBranch <- expr
156 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
157 elseBranch <- expr
158 return $ MultiIf [(bool, thenBranch),
159 (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
160 multiIf = MultiIf <$> spaceSep1 iff
161 where iff = do string "|" ; whitespace
162 b <- expr ; padded arrow
163 (,) b <$> expr
165lambdaExpr :: IParser ParseExpr
166lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
167 whitespace
168 args <- spaceSep1 Pattern.term
169 padded arrow
170 body <- expr
171 return (makeFunction args body)
173defSet :: IParser [ParseDef]
174defSet = block (do d <- def ; whitespace ; return d)
176letExpr :: IParser ParseExpr'
177letExpr = do
178 reserved "let" ; whitespace
179 defs <- defSet
180 padded (reserved "in")
181 Let defs <$> expr
183caseExpr :: IParser ParseExpr'
184caseExpr = do
185 reserved "case"; e <- padded expr; reserved "of"; whitespace
186 Case e <$> (with <|> without)
187 where case_ = do p <- Pattern.expr
188 padded arrow
189 (,) p <$> expr
190 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
191 without = block (do c <- case_ ; whitespace ; return c)
193expr :: IParser ParseExpr
194expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
195 <|> lambdaExpr
196 <|> binaryExpr
197 <?> "an expression"
199defStart :: IParser [P.Pattern]
200defStart =
201 choice [ do p1 <- try Pattern.term
202 infics p1 <|> func p1
203 , func =<< (P.Var <$> parens symOp)
204 , (:[]) <$> Pattern.expr
205 ] <?> "the definition of a variable (x = ...)"
206 where
207 func pattern =
208 case pattern of
209 P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
210 _ -> do try (lookAhead (whitespace >> string "="))
211 return [pattern]
213 infics p1 = do
214 o:p <- try (whitespace >> anyOp)
215 p2 <- (whitespace >> Pattern.term)
216 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
217 else [ P.Var (o:p), p1, p2 ]
219makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
220makeFunction args body@(A ann _) =
221 foldr (\arg body' -> A ann $ Lambda arg body') body args
223definition :: IParser ParseDef
224definition = withPos $ do
225 (name:args) <- defStart
226 padded equals
227 body <- expr
228 return . Def name $ makeFunction args body
230typeAnnotation :: IParser ParseDef
231typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
232 where
233 start = do
234 v <- lowVar <|> parens symOp
235 padded hasType
236 return v
238def :: IParser ParseDef
239def = typeAnnotation <|> definition