git.iko.soy/elk
on 727d708 help sign in
elk/compiler/Parse/Expression.hs
242 lines 8.0 kB history raw
1module Parse.Expression {-(def,term)-} where
3import Control.Applicative ((<$>), (<*>))
4import Data.List (foldl')
5import Text.Parsec hiding (newline,spaces)
6import Text.Parsec.Indent
7import qualified Text.Pandoc as Pan
9import Parse.Helpers
10import qualified Parse.Pattern as Pattern
11import qualified Parse.Type as Type
12import Parse.Binop
13import Parse.Literal
15import SourceSyntax.Location as Location
16import SourceSyntax.Pattern hiding (tuple,list)
17import qualified SourceSyntax.Literal as Literal
18import SourceSyntax.Expression
19import SourceSyntax.Declaration (Declaration(Definition))
21import Unique
24-------- Basic Terms --------
26varTerm :: IParser (Expr t v)
27varTerm = toVar <$> var <?> "variable"
29toVar :: String -> Expr t v
30toVar v = case v of "True" -> Literal (Literal.Boolean True)
31 "False" -> Literal (Literal.Boolean False)
32 _ -> Var v
34accessor :: IParser (Expr t v)
35accessor = do
36 start <- getPosition
37 lbl <- try (string "." >> rLabel)
38 end <- getPosition
39 let loc e = Location.add ("." ++ lbl) (Location.at start end e)
40 return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
42negative :: IParser (Expr t v)
43negative = do
44 start <- getPosition
45 nTerm <- try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term
46 end <- getPosition
47 let loc e = Location.at start end e
48 return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
51-------- Complex Terms --------
53listTerm :: IParser (Expr t v)
54listTerm =
55 (do { try $ string "[markdown|"
56 ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
57 ; return . Markdown $ Pan.readMarkdown Pan.def md })
58 <|> (braces $ choice
59 [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
60 ; Range lo <$> expr }
61 , ExplicitList <$> commaSep expr
62 ])
64parensTerm :: IParser (LExpr t v)
65parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
66 where
67 opFn = do
68 start <- getPosition
69 op <- anyOp
70 end <- getPosition
71 let loc = Location.at start end
72 return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
73 Binop op (loc $ Var "x") (loc $ Var "y")
75 tupleFn = do
76 start <- getPosition
77 let comma = char ',' <?> "comma ','"
78 commas <- comma >> many (whitespace >> comma)
79 end <- getPosition
80 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
81 loc = Location.at start end
82 return $ foldr (\x e -> loc $ Lambda x e)
83 (loc . tuple $ map (loc . Var) vars) (map PVar vars)
85 parened = do
86 start <- getPosition
87 es <- commaSep expr
88 end <- getPosition
89 return $ case es of [e] -> e
90 _ -> Location.at start end (tuple es)
92recordTerm :: IParser (LExpr t v)
93recordTerm = brackets $ choice [ misc, addLocation record ]
94 where field = do
95 label <- rLabel
96 patterns <- spacePrefix Pattern.term
97 whitespace >> string "=" >> whitespace
98 body <- expr
99 return (label, makeFunction patterns body)
101 record = Record <$> commaSep field
103 change = do
104 lbl <- rLabel
105 whitespace >> string "<-" >> whitespace
106 (,) lbl <$> expr
108 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
110 insert r = addLocation $ do
111 string "|" >> whitespace
112 Insert r <$> rLabel <*>
113 (whitespace >> string "=" >> whitespace >> expr)
115 modify r = addLocation
116 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
118 misc = try $ do
119 record <- addLocation (Var <$> rLabel)
120 whitespace
121 opt <- optionMaybe (remove record)
122 whitespace
123 case opt of
124 Just e -> try (insert e) <|> return e
125 Nothing -> try (insert record) <|> try (modify record)
128term :: IParser (LExpr t v)
129term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
130 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
131 <?> "basic term (4, x, 'c', etc.)"
133-------- Applications --------
135appExpr :: IParser (LExpr t v)
136appExpr = do
137 t <- term
138 ts <- constrainedSpacePrefix term $ \str ->
139 if null str then notFollowedBy (char '-') else return ()
140 return $ case ts of
141 [] -> t
142 _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
144-------- Normal Expressions --------
146binaryExpr :: IParser (LExpr t v)
147binaryExpr = binops [] appExpr lastExpr anyOp
148 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
149 <|> lambdaExpr
151ifExpr :: IParser (Expr t v)
152ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
153 where
154 normal = do
155 bool <- expr
156 whitespace ; reserved "then" ; whitespace
157 thenBranch <- expr
158 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
159 elseBranch <- expr
160 return $ MultiIf [(bool, thenBranch), (Location.none (Var "otherwise"), elseBranch)]
161 multiIf = MultiIf <$> spaceSep1 iff
162 where iff = do string "|" ; whitespace
163 b <- expr ; whitespace ; string "->" ; whitespace
164 (,) b <$> expr
166lambdaExpr :: IParser (LExpr t v)
167lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
168 whitespace
169 args <- spaceSep1 Pattern.term
170 whitespace ; arrow ; whitespace
171 body <- expr
172 return (makeFunction args body)
174defSet :: IParser [Def t v]
175defSet = block (do d <- def ; whitespace ; return d)
177letExpr :: IParser (Expr t v)
178letExpr = do
179 reserved "let" ; whitespace
180 defs <- defSet
181 whitespace ; reserved "in" ; whitespace
182 Let defs <$> expr
184caseExpr :: IParser (Expr t v)
185caseExpr = do
186 reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
187 Case e <$> (with <|> without)
188 where case_ = do p <- Pattern.expr; whitespace; arrow; whitespace
189 (,) p <$> expr
190 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
191 without = block (do c <- case_ ; whitespace ; return c)
193expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
194 <|> lambdaExpr
195 <|> binaryExpr
196 <?> "an expression"
198funcDef =
199 choice [ do p1 <- try Pattern.term
200 infics p1 <|> func p1
201 , func =<< (PVar <$> parens symOp)
202 , (:[]) <$> Pattern.expr
203 ] <?> "the definition of a variable (x = ...)"
204 where
205 func pattern =
206 case pattern of
207 PVar v -> (pattern:) <$> spacePrefix Pattern.term
208 _ -> do try (lookAhead (whitespace >> string "="))
209 return [pattern]
211 infics p1 = do
212 o:p <- try (whitespace >> anyOp)
213 p2 <- (whitespace >> Pattern.term)
214 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
215 else [ PVar (o:p), p1, p2 ]
217makeFunction :: [Pattern] -> LExpr t v -> LExpr t v
218makeFunction args body@(L a b _) =
219 let pos = L a b in
220 foldr (\arg body' -> pos $ Lambda arg body') body args
222assignExpr :: IParser (Def t v)
223assignExpr = withPos $ do
224 (name:args) <- funcDef
225 whitespace >> string "=" >> whitespace
226 body <- expr
227 return . Def name $ makeFunction args body
229typeAnnotation :: IParser (Def t v)
230typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
231 where
232 start = do v <- lowVar <|> parens symOp
233 whitespace ; hasType ; whitespace
234 return v
236def :: IParser (Def t v)
237def = typeAnnotation <|> assignExpr
239attempt f parser str =
240 case iParse parser "" str of
241 Right result -> f result
242 Left err -> error $ "Parse error at " ++ show err