git.iko.soy/elk
on master help sign in
Redo parsers for expressions, patterns, types, and literals

Benefits include: - Almost no backtracking! Only eat whitespace once. The only backtrack is for detecting when operators like (+) are defined. - Parsers for application, infix ops, negated terms, and field access are combined, making it clearer how they all interact. Work remaining: - Multiline strings do not work. - Error messages are mostly TODO - Everything outside expressions (doc comments, declarations, etc.)

commitb4f1e8b8b64a1de9b07e13c487b4ec20191117ce authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 30 Nov 2016, 16:38 (10 years ago) parentc0b4375
6 files changed+1062−1007
compare with master
unifiedsplit
src/Parse/Expression.hs+429−263 src/Parse/Helpers.hs+128−361 src/Parse/Literal.hs+32−195 src/Parse/Pattern.hs+177−84 src/Parse/Primitives.hs+131−22 src/Parse/Type.hs+165−82
src/Parse/Expression.hs+429−263
@@ -1,333 +1,499 @@
1−module Parse.Expression (term, expr, def) where
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Parse.Expression (term, expression, definition) where
24
5+import Control.Monad (guard)
36import qualified Data.List as List
4−import Text.Parsec hiding (newline, spaces)
7+import qualified Data.Text as Text
8+import Data.Text (Text)
59
6−import qualified Parse.Binop as Binop
710import Parse.Helpers
8−import qualified Parse.Helpers as Help
911import qualified Parse.Literal as Literal
1012import qualified Parse.Pattern as Pattern
1113import qualified Parse.Type as Type
1214
1315import qualified AST.Expression.Source as Src
14−import qualified AST.Literal as L
1516import qualified AST.Pattern as P
1617import qualified Reporting.Annotation as A
18+import qualified Reporting.Region as R
1719
1820
1921
20−-------- Basic Terms --------
22+-- TERMS
2123
2224
23−varTerm :: IParser Src.RawExpr'
24−varTerm =
25− toVar <$> Help.var
25+term :: Parser Src.RawExpr
26+term =
27+ do start <- getPosition
28+ oneOf
29+ [ do literal <- Literal.literal
30+ end <- getPosition
31+ return (A.at start end (Src.Literal literal))
32+ , list start
33+ , tuple start
34+ , record start
35+ , do var <- qualifiedVar
36+ end <- getPosition
37+ return (A.at start end (Src.var var))
38+ ]
2639
2740
28−toVar :: String -> Src.RawExpr'
29−toVar v =
30− case v of
31− "True" ->
32− Src.Literal (L.Boolean True)
3341
34− "False" ->
35− Src.Literal (L.Boolean False)
42+-- LISTS
3643
37− _ ->
38− Src.var v
3944
45+list :: R.Position -> Parser Src.RawExpr
46+list start =
47+ do leftSquare
48+ spaces
49+ oneOf
50+ [ do (entry, _, space) <- expression
51+ checkSpaces space
52+ listHelp start [entry]
53+ , do rightSquare
54+ end <- getPosition
55+ return (A.at start end (Src.List []))
56+ ]
4057
41−accessor :: IParser Src.RawExpr'
42−accessor =
43− do start <- getMyPosition
44− label <- try (char '.' >> rLabel)
45− end <- getMyPosition
4658
47− let ann value =
48− A.at start end value
59+listHelp :: R.Position -> [Src.RawExpr] -> Parser Src.RawExpr
60+listHelp start entries =
61+ oneOf
62+ [ do comma
63+ spaces
64+ (entry, _, space) <- expression
65+ checkSpaces space
66+ listHelp start (entry:entries)
67+ , do rightSquare
68+ end <- getPosition
69+ return (A.at start end (Src.List (reverse entries)))
70+ ]
4971
50− return $
51− Src.Lambda
52− (ann (P.Var "_"))
53− (ann (Src.Access (ann (Src.var "_")) label))
5472
5573
56−negative :: IParser Src.RawExpr'
57−negative =
58− try $
59− do (A.A region _) <- addLocation (char '-')
60− notFollowedBy (char '.' <|> char '-')
61− negativeTerm <- term
74+-- TUPLES
6275
63− let zero = A.A region (Src.Literal (L.IntNum 0))
64− let minus = A.A region "-"
6576
66− return $ Src.Binop [(zero, minus)] negativeTerm
77+tuple :: R.Position -> Parser Src.RawExpr
78+tuple start =
79+ do leftParen
80+ oneOf
81+ [ do op <- infixOp
82+ rightParen
83+ end <- getPosition
84+ let x = A.at start end (Src.var "x")
85+ let y = A.at start end (Src.var "y")
86+ return $ mkLambda start end "x" $ mkLambda start end "y" $
87+ A.at start end (Src.Binop [(x, A.at start end op)] y)
6788
89+ , do comma
90+ arity <- chompCommas 2
91+ rightParen
92+ end <- getPosition
93+ let args = map (\n -> Text.pack ("v" ++ show n)) [ 1 .. arity ]
94+ return (A.at start end (error "TODO" args))
6895
96+ , do spaces
97+ (entry, _, space) <- expression
98+ checkSpaces space
99+ tupleHelp start [entry]
100+ ]
69101
70102
71−-------- Complex Terms --------
103+mkLambda :: R.Position -> R.Position -> Text -> Src.RawExpr -> Src.RawExpr
104+mkLambda start end arg body =
105+ A.at start end (Src.Lambda (A.at start end (P.Var arg)) body)
72106
73107
74−listTerm :: IParser Src.RawExpr'
75−listTerm =
76− choice
77− [ do pos <- getPosition
78− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
79− (rawSrc, tipe) <- Literal.shader
80− return $ Src.GLShader uid (filter (/='\r') rawSrc) tipe
81− , braces (Src.List <$> commaSep expr)
108+chompCommas :: Int -> Parser Int
109+chompCommas n =
110+ oneOf
111+ [ comma >> chompCommas (n + 1)
112+ , return n
82113 ]
83114
84115
85−parensTerm :: IParser Src.RawExpr
86−parensTerm =
87− let
88− mkFunc args realBody start end =
89− foldr
90− (\arg body -> A.at start end (Src.Lambda (A.at start end (P.Var arg)) body))
91− (A.at start end (realBody (A.at start end . Src.var)))
92− args
93−
94− mkBinop op =
95− mkFunc ["x","y"] $ \var -> Src.Binop [(var "x", op)] (var "y")
96−
97− tupleFn =
98− do commas <- many1 comma
99− let args = map (('v':) . show) [ 0 .. length commas ]
100− return $ mkFunc args (\var -> Src.tuple (map var args))
101−
102− parenedExpr =
103− do expressions <- padded (commaSep expr)
104− return $ \start end ->
105− case expressions of
106− [expression] ->
107− expression
108− _ ->
109− A.at start end (Src.tuple expressions)
110− in
111− do char '('
112− start <- getMyPosition
113− mkExpr <-
114− choice
115− [ mkBinop <$> try (addLocation Binop.infixOp)
116− , tupleFn
117− , parenedExpr
118− ]
119− end <- getMyPosition
120− char ')'
121− return (mkExpr start end)
122−
123−
124−recordTerm :: IParser Src.RawExpr
125−recordTerm =
126− addLocation $ brackets $ choice $
127− [ do starter <- try (addLocation rLabel)
128− whitespace
129− choice
130− [ update starter
131− , literal starter
132− ]
133− , return (Src.Record [])
116+tupleHelp :: R.Position -> [Src.RawExpr] -> Parser Src.RawExpr
117+tupleHelp start entries =
118+ oneOf
119+ [ do comma
120+ spaces
121+ (entry, _, space) <- expression
122+ checkSpaces space
123+ tupleHelp start (entry:entries)
124+ , do rightParen
125+ end <- getPosition
126+ case entries of
127+ [entry] ->
128+ return entry
129+
130+ _ ->
131+ return (A.at start end (Src.tuple (reverse entries)))
134132 ]
135− where
136− update (A.A ann starter) =
137− do try (string "|")
138− whitespace
139− fields <- commaSep1 field
140− return (Src.Update (A.A ann (Src.var starter)) fields)
141−
142− literal key =
143− do try equals
144− whitespace
145− value <- expr
146− whitespace
147− choice
148− [ do comma
149− whitespace
150− fields <- commaSep field
151− return (Src.Record ((key, value) : fields))
152− , return (Src.Record [(key, value)])
153− ]
154133
155− field =
156− do key <- addLocation rLabel
157− padded equals
158− value <- expr
159− return (key, value)
160134
161135
162−term :: IParser Src.RawExpr
163−term =
164− choice
165− [ addLocation $ choice $
166− [ Src.Literal <$> Literal.literal
167− , listTerm
168− , accessor
169− , negative
170− ]
171− , accessible $ choice $
172− [ addLocation varTerm
173− , parensTerm
174− , recordTerm
136+-- RECORDS
137+
138+
139+record :: R.Position -> Parser Src.RawExpr
140+record start =
141+ do leftCurly
142+ spaces
143+ oneOf
144+ [ do rightCurly
145+ end <- getPosition
146+ return (A.at start end (Src.Record []))
147+ , do starter <- addLocation lowVar
148+ spaces
149+ oneOf
150+ [ do pipe
151+ spaces
152+ firstField <- chompField
153+ fields <- chompFields [firstField]
154+ end <- getPosition
155+ return (A.at start end (Src.Update (A.map Src.var starter) fields))
156+ , do equals
157+ spaces
158+ (value, _, nextSpace) <- expression
159+ checkSpaces nextSpace
160+ fields <- chompFields [(starter, value)]
161+ end <- getPosition
162+ return (A.at start end (Src.Record fields))
163+ ]
175164 ]
165+
166+
167+type Field = ( A.Located Text, Src.RawExpr )
168+
169+
170+chompFields :: [Field] -> Parser [Field]
171+chompFields fields =
172+ oneOf
173+ [ do comma
174+ spaces
175+ f <- chompField
176+ chompFields (f : fields)
177+ , do rightCurly
178+ return fields
176179 ]
177− <?> "an expression"
178180
179181
182+chompField :: Parser Field
183+chompField =
184+ do key <- addLocation lowVar
185+ spaces
186+ equals
187+ spaces
188+ (value, _, endSpace) <- expression
189+ checkSpaces endSpace
190+ return (key, value)
191+
180192
181−-------- Applications --------
182193
194+-- EXPRESSIONS
183195
184−appExpr :: IParser Src.RawExpr
185−appExpr =
186− expecting "an expression" $
187− do t <- term
188− ts <- constrainedSpacePrefix term $ \hasSpace ->
189− if hasSpace then return () else notFollowedBy (char '-')
190− return $
191− case ts of
192− [] -> t
193− _ -> List.foldl' (\f x -> A.merge f x $ Src.App f x) t ts
194196
197+type ExprParser =
198+ SParser Src.RawExpr
199+
200+
201+expression :: ExprParser
202+expression =
203+ do start <- getPosition
204+ oneOf
205+ [ let_ start
206+ , if_ start
207+ , case_ start
208+ , function start
209+ , do starter <- term
210+ end <- getPosition
211+ space <- whitespace
212+ exprHelp start (State [] starter end space)
213+ ]
195214
196215
197−-------- Normal Expressions --------
216+data State =
217+ State
218+ { _ops :: ![(Src.RawExpr, A.Located Text)]
219+ , _last :: !Src.RawExpr
220+ , _end :: !R.Position
221+ , _space :: !Space
222+ }
223+
224+
225+exprHelp :: R.Position -> State -> ExprParser
226+exprHelp start (State ops lastExpr end space) =
227+ oneOf
228+ [ -- infix operator
229+ do checkSpaces space
230+ op <- addLocation infixOp
231+ opSpace <- whitespace
232+ oneOf
233+ [ -- negative terms
234+ do guard (space /= None && opSpace == None && A.drop op == "-")
235+ rawTerm <- term
236+ newEnd <- getPosition
237+ newSpace <- whitespace
238+
239+ let ann x = A.merge op rawTerm x
240+ let negatedTerm = ann (Src.Binop [(ann Src.zero, op)] rawTerm)
241+ let newLast = A.merge lastExpr rawTerm (Src.App lastExpr negatedTerm)
242+
243+ exprHelp start (State ops newLast newEnd newSpace)
244+
245+ , -- accessor
246+ do guard (space /= None && opSpace == None && A.drop op == ".")
247+ field <- lowVar
248+ newEnd <- getPosition
249+ newSpace <- whitespace
250+
251+ let (A.A (R.Region opStart _) _) = op
252+ let ann x = A.at opStart newEnd x
253+ let body = ann (Src.Access (ann (Src.var "r")) field)
254+ let accessor = mkLambda opStart newEnd "r" body
255+ let newLast = A.merge lastExpr accessor (Src.App lastExpr accessor)
256+
257+ exprHelp start (State ops newLast newEnd newSpace)
258+
259+ , -- access
260+ do guard (space == None && opSpace == None && A.drop op == ".")
261+ field <- lowVar
262+ newEnd <- getPosition
263+ newSpace <- whitespace
264+ let (A.A (R.Region lastStart _) _) = lastExpr
265+ let newLast = A.at lastStart newEnd (Src.Access lastExpr field)
266+ exprHelp start (State ops newLast newEnd newSpace)
267+
268+ , -- term
269+ do checkSpaces opSpace
270+ newLast <- term
271+ newEnd <- getPosition
272+ newSpace <- whitespace
273+ let newOps = (lastExpr, op) : ops
274+ exprHelp start (State newOps newLast newEnd newSpace)
275+
276+ , -- final term
277+ do checkSpaces opSpace
278+ newStart <- getPosition
279+ (newLast, newEnd, newSpace) <-
280+ oneOf
281+ [ let_ newStart
282+ , case_ newStart
283+ , if_ newStart
284+ , function newStart
285+ ]
286+ let newOps = (lastExpr, op) : ops
287+ let finalExpr = A.at start newEnd (Src.Binop (reverse newOps) newLast)
288+ return ( finalExpr, newEnd, newSpace )
289+ ]
198290
291+ , -- argument
292+ do checkSpaces space
293+ arg <- term
294+ newEnd <- getPosition
295+ newSpace <- whitespace
296+ let newLast = A.merge lastExpr arg (Src.App lastExpr arg)
297+ exprHelp start (State ops newLast newEnd newSpace)
298+
299+ , -- done
300+ case ops of
301+ [] ->
302+ return ( lastExpr, end, space )
303+
304+ _ ->
305+ let
306+ finalExpr =
307+ A.at start end (Src.Binop (reverse ops) lastExpr)
308+ in
309+ return ( finalExpr, end, space )
310+ ]
199311
200−expr :: IParser Src.RawExpr
201−expr =
202− addLocation (choice [ letExpr, caseExpr, ifExpr ])
203− <|> lambdaExpr
204− <|> binaryExpr
205− <?> "an expression"
206312
207313
208−binaryExpr :: IParser Src.RawExpr
209−binaryExpr =
210− Binop.binops appExpr lastExpr
211− where
212− lastExpr =
213− addLocation (choice [ letExpr, caseExpr, ifExpr ])
214− <|> lambdaExpr
215− <?> "an expression"
314+-- IF EXPRESSION
216315
217316
218−ifExpr :: IParser Src.RawExpr'
219−ifExpr =
220− ifHelp []
317+if_ :: R.Position -> ExprParser
318+if_ start =
319+ ifHelp start []
221320
222321
223−ifHelp :: [(Src.RawExpr, Src.RawExpr)] -> IParser Src.RawExpr'
224−ifHelp branches =
225− do try (reserved "if")
226− whitespace
227− condition <- expr
228− padded (reserved "then")
229− thenBranch <- expr
230− whitespace <?> "an 'else' branch"
231− reserved "else" <?> "an 'else' branch"
232− whitespace
322+ifHelp :: R.Position -> [(Src.RawExpr, Src.RawExpr)] -> ExprParser
323+ifHelp start branches =
324+ do keyword "if"
325+ spaces
326+ (condition, _, condSpace) <- expression
327+ checkSpaces condSpace
328+ keyword "then"
329+ spaces
330+ (thenBranch, _, thenSpace) <- expression
331+ checkSpaces thenSpace
332+ keyword "else"
333+ spaces
233334 let newBranches = (condition, thenBranch) : branches
234− choice
235− [ ifHelp newBranches
236− , Src.If (reverse newBranches) <$> expr
335+ oneOf
336+ [ ifHelp start newBranches
337+ , do (elseBranch, elseEnd, elseSpace) <- expression
338+ let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)
339+ return ( ifExpr, elseEnd, elseSpace )
237340 ]
238341
239342
240−lambdaExpr :: IParser Src.RawExpr
241−lambdaExpr =
242− do start <- getMyPosition
243− char '\\' <|> char '\x03BB' <?> "an anonymous function"
244− whitespace
245− args <- spaceSep1 Pattern.term
246− padded rightArrow
247− body <- expr
248− end <- getMyPosition
249− return (foldr (\a b -> A.at start end $ Src.Lambda a b) body args)
250−
251−
252−caseExpr :: IParser Src.RawExpr'
253−caseExpr =
254− do try (reserved "case")
255− exp <- padded expr
256− reserved "of"
257− whitespace
258− Help.withPos $
259− do firstBranch <- branch
260− branches <-
261− many $ do
262− try (whitespace >> Help.checkIndent)
263− branch
264− return $ Src.Case exp (firstBranch : branches)
265− where
266− branch =
267− do p <- Pattern.expr
268− padded rightArrow
269− (,) p <$> expr
270−
271−
272−
273−-- LET
274−
275−
276−letExpr :: IParser Src.RawExpr'
277−letExpr =
278− do try (reserved "let")
279− whitespace
280− defs <- Help.block (def <* whitespace)
281− whitespace
282− reserved "in"
283− whitespace
284− Src.Let defs <$> expr
285−
286−
287−def :: IParser Src.RawDef
288−def =
289− addLocation $ Help.withPos $
290− do start <- defStart
291− whitespace
292− case start of
293− A.A _ (P.Var name) ->
294− choice
295− [ do hasType
296− whitespace
297− tipe <- Type.expr
298− return $ Src.Annotation name tipe
299− , defEnd start []
300− ]
301−
302− _ ->
303− defEnd start []
304−
305−
306−defStart :: IParser P.Raw
307−defStart =
308− choice
309− [ addLocation $ try $
310− do char '('
311− op <- Binop.infixOp
312− char ')'
313− return (P.Var op)
343+
344+-- LAMBDA EXPRESSION
345+
346+
347+function :: R.Position -> ExprParser
348+function start =
349+ do lambda
350+ spaces
351+ arg <- Pattern.term
352+ spaces
353+ revArgs <- gatherArgs [arg]
354+ spaces
355+ (body, end, space) <- expression
356+ let func = List.foldl' (\e x -> A.at start end (Src.Lambda x e)) body revArgs
357+ return ( func, end, space )
358+
359+
360+gatherArgs :: [P.Raw] -> Parser [P.Raw]
361+gatherArgs args =
362+ oneOf
363+ [ do arg <- Pattern.term
364+ spaces
365+ gatherArgs (arg:args)
366+ , do rightArrow
367+ return args
368+ ]
369+
370+
371+
372+-- CASE EXPRESSIONS
373+
374+
375+case_ :: R.Position -> ExprParser
376+case_ start =
377+ do keyword "case"
378+ spaces
379+ (switcher, _, switcherSpace) <- expression
380+ checkSpaces switcherSpace
381+ keyword "of"
382+ spaces
383+ oldIndent <- getIndent
384+ newIndent <- getCol
385+ setIndent newIndent
386+ (firstBranch, firstEnd, firstSpace) <- branchHelp
387+ (branches, end, space) <- caseHelp [firstBranch] firstEnd firstSpace
388+ setIndent oldIndent
389+ return
390+ ( A.at start end (Src.Case switcher branches)
391+ , end
392+ , space
393+ )
394+
395+
396+branchHelp :: SParser (P.Raw, Src.RawExpr)
397+branchHelp =
398+ do (pattern, patternSpace) <- Pattern.expression
399+ checkSpaces patternSpace
400+ rightArrow
401+ spaces
402+ (branchExpr, end, space) <- expression
403+ return ( (pattern, branchExpr), end, space )
404+
405+
406+caseHelp :: [(P.Raw, Src.RawExpr)] -> R.Position -> Space -> SParser [(P.Raw, Src.RawExpr)]
407+caseHelp branches end space =
408+ case space of
409+ Aligned ->
410+ do (branch, newEnd, newSpace) <- branchHelp
411+ caseHelp (branch:branches) newEnd newSpace
412+
413+ _ ->
414+ return ( reverse branches, end, space )
415+
416+
417+
418+-- LET EXPRESSION
419+
420+
421+let_ :: R.Position -> ExprParser
422+let_ start =
423+ do oldIndent <- getIndent
424+ letIndent <- getCol
425+ keyword "let"
426+ setIndent letIndent
427+ spaces
428+ defIndent <- getCol
429+ setIndent defIndent
430+ (def, end, space) <- definition
431+ letHelp start oldIndent [def] end space
432+
433+
434+letHelp :: R.Position -> Int -> [Src.RawDef] -> R.Position -> Space -> ExprParser
435+letHelp start oldIndent defs end space =
436+ case space of
437+ Aligned ->
438+ do (def, newEnd, newSpace) <- definition
439+ letHelp start oldIndent (def:defs) newEnd newSpace
440+
441+ Freshline ->
442+ failure (error "TODO missing `in`")
443+
444+ _ ->
445+ do keyword "in"
446+ setIndent oldIndent
447+ spaces
448+ (body, newEnd, newSpace) <- expression
449+ let letExpr = A.at start end (Src.Let defs body)
450+ return ( letExpr, newEnd, newSpace )
451+
452+
453+
454+-- DEFINITIONS
455+
456+
457+definition :: SParser Src.RawDef
458+definition =
459+ do start <- getPosition
460+ root <- rootPattern start
461+ spaces
462+ case A.drop root of
463+ P.Var name ->
464+ oneOf
465+ [ do hasType
466+ spaces
467+ (tipe, end, space) <- Type.expression
468+ return ( A.at start end (Src.Annotation name tipe), end, space )
469+ , definitionHelp start root []
470+ ]
471+
472+ _ ->
473+ definitionHelp start root []
474+
475+
476+rootPattern :: R.Position -> Parser P.Raw
477+rootPattern start =
478+ oneOf
479+ [ do op <- try (leftParen >> infixOp)
480+ rightParen
481+ end <- getPosition
482+ return (A.at start end (P.Var op))
314483 , Pattern.term
315484 ]
316485
317486
318−defEnd :: P.Raw -> [P.Raw] -> IParser Src.RawDef'
319−defEnd start revArgs =
320− choice
487+definitionHelp :: R.Position -> P.Raw -> [P.Raw] -> SParser Src.RawDef
488+definitionHelp start root revArgs =
489+ oneOf
321490 [ do arg <- Pattern.term
322− whitespace
323− defEnd start (arg : revArgs)
491+ spaces
492+ definitionHelp start root (arg : revArgs)
324493 , do equals
325− whitespace
326− body <- expr
327− return $ Src.Definition start (makeFunction revArgs body)
494+ spaces
495+ (expr, end, space) <- expression
496+ let body = List.foldl' (\e x -> A.at start end (Src.Lambda x e)) expr revArgs
497+ let def = A.at start end (Src.Definition root body)
498+ return ( def, end, space )
328499 ]
329−
330−
331−makeFunction :: [P.Raw] -> Src.RawExpr -> Src.RawExpr
332−makeFunction revArgs body@(A.A ann _) =
333− List.foldl' (\expr arg -> A.A ann $ Src.Lambda arg expr) body revArgs
src/Parse/Helpers.hs+128−361
@@ -1,96 +1,66 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module Parse.Helpers
34 ( module Parse.Primitives
4− , var, lowVar, capVar, rLabel, reserved, reserveds
5− , equals, rightArrow, hasType
6− , commitIf, followedBy, anyUntil
7− , comma, commaSep1, commaSep
8− , pipeSep1, consSep1, dotSep1, spaceSep1, spacePrefix, constrainedSpacePrefix
9− , braces, parens, brackets
10− , accessible
11− , getMyPosition, addLocation, located
12− , whitespace, freshLine, simpleNewline, newline, spaces
13− , forcedWS, padded, dumbWhitespace, docComment
5+ , SParser
6+ , qualifiedVar, qualifiedCapVar
7+ , equals, rightArrow, hasType, comma, pipe, cons, dot, underscore, lambda
8+ , leftParen, rightParen, leftSquare, rightSquare, leftCurly, rightCurly
9+ , addLocation
10+ , spaces, checkSpaces
1411 )
1512 where
1613
17−import Data.Char (isUpper)
18−import qualified Data.Set as Set
19−import Text.Parsec hiding (newline, space, spaces)
14+import qualified Data.Text as Text
15+import Data.Text (Text)
2016
21−import qualified AST.Expression.Source as Src
22−import qualified AST.Variable as Variable
23−import Parse.Primitives
17+import Parse.Primitives hiding (text)
18+import qualified Parse.Primitives as Prim
2419import qualified Reporting.Annotation as A
25−import qualified Reporting.Error.Syntax as Syntax
2620import qualified Reporting.Region as R
2721
2822
2923
30−-- VARIABLES
31−
32−
33−var :: IParser String
34−var =
35− makeVar letter <?> "a name"
36−
37−
38−lowVar :: IParser String
39−lowVar =
40− makeVar lower <?> "a lower case name"
24+-- SPACE PARSER
4125
4226
43−capVar :: IParser String
44−capVar =
45− makeVar upper <?> "an upper case name"
27+type SParser a =
28+ Parser (a, R.Position, Space)
4629
4730
48−rLabel :: IParser String
49−rLabel =
50− lowVar
5131
52−
53−innerVarChar :: IParser Char
54−innerVarChar =
55− alphaNum <|> char '_' <?> "more letters in this name"
32+-- VARIABLES
5633
5734
58−makeVar :: IParser Char -> IParser String
59−makeVar firstChar =
60− do variable <- (:) <$> firstChar <*> many innerVarChar
61− choice
62− [ do lookAhead (char '\'')
63− failure (Syntax.prime variable)
64− , if Set.member variable reserveds then
65− failure (Syntax.keyword variable)
66− else
67− return variable
68− ]
35+qualifiedCapVar :: Parser Text
36+qualifiedCapVar =
37+ do var <- capVar
38+ qualifiedVarHelp True [var]
6939
7040
71−reserved :: String -> IParser String
72−reserved word =
73− expecting ("reserved word `" ++ word ++ "`") $
74− do string word
75− choice
76− [ do lookAhead (char '\'')
77− failure (Syntax.prime word)
78− , do notFollowedBy innerVarChar
79− return word
80− ]
41+qualifiedVar :: Parser Text
42+qualifiedVar =
43+ oneOf
44+ [ lowVar
45+ , do var <- capVar
46+ qualifiedVarHelp False [var]
47+ ]
8148
8249
83−reserveds :: Set.Set String
84−reserveds =
85− Set.fromList
86− [ "if", "then", "else"
87− , "case", "of"
88− , "let", "in"
89− , "type"
90− , "module", "where"
91− , "import", "exposing"
92− , "as"
93− , "port"
50+qualifiedVarHelp :: Bool -> [Text] -> Parser Text
51+qualifiedVarHelp allCaps vars =
52+ oneOf
53+ [ do dot
54+ oneOf
55+ [ do var <- capVar
56+ qualifiedVarHelp allCaps (var:vars)
57+ , if allCaps then
58+ failure (error "TODO")
59+ else
60+ do var <- lowVar
61+ return (Text.intercalate "." (reverse (var:vars)))
62+ ]
63+ , return (Text.intercalate "." (reverse vars))
9464 ]
9565
9666
@@ -98,346 +68,143 @@ reserveds =
9868-- COMMON SYMBOLS
9969
10070
101−equals :: IParser String
71+{-# INLINE equals #-}
72+equals :: Parser ()
10273equals =
103− string "=" <?> "an equals sign '='"
74+ expecting "an equals sign '='" $
75+ Prim.text "="
10476
10577
106−rightArrow :: IParser String
78+{-# INLINE rightArrow #-}
79+rightArrow :: Parser ()
10780rightArrow =
108− string "->" <?> "an arrow '->'"
81+ expecting "an arrow '->'" $
82+ Prim.text "->"
10983
11084
111−hasType :: IParser String
85+{-# INLINE hasType #-}
86+hasType :: Parser ()
11287hasType =
113− string ":" <?> "the \"has type\" symbol ':'"
114−
115−
116−
117−-- WEIRD COMBINATORS
118−
119−
120−commitIf :: IParser a -> IParser b -> IParser b
121−commitIf check p =
122− commit <|> try p
123− where
124− commit =
125− try (lookAhead check) >> p
126−
127−
128−anyUntil :: IParser () -> IParser ()
129−anyUntil end =
130− let
131− go =
132− end <|> (anyChar >> go)
133− in
134− go
135−
88+ expecting "the \"has type\" symbol ':'" $
89+ Prim.text ":"
13690
137−followedBy :: IParser a -> IParser b -> IParser a
138−followedBy a b =
139− do x <- a
140− b
141− return x
14291
143−
144−
145−-- SEPARATORS
146−
147−
148−spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
149−spaceySepBy1 sep parser =
150− do value <- parser
151− (value:) <$> spaceyPrefixBy sep parser
152−
153−
154−spaceyPrefixBy :: IParser sep -> IParser a -> IParser [a]
155−spaceyPrefixBy sep parser =
156− many (commitIf (whitespace >> sep) (padded sep >> parser))
157−
158−
159−comma :: IParser Char
92+{-# INLINE comma #-}
93+comma :: Parser ()
16094comma =
161− char ',' <?> "a comma ','"
95+ expecting "a comma ','" $
96+ Prim.text ","
16297
16398
164−commaSep1 :: IParser a -> IParser [a]
165−commaSep1 =
166− spaceySepBy1 comma
99+{-# INLINE pipe #-}
100+pipe :: Parser ()
101+pipe =
102+ expecting "a vertical bar '|'" $
103+ Prim.text "|"
167104
168105
169−commaSep :: IParser a -> IParser [a]
170−commaSep =
171− option [] . commaSep1
106+{-# INLINE cons #-}
107+cons :: Parser ()
108+cons =
109+ expecting "a cons operator '::'" $
110+ Prim.text "::"
172111
173112
174−pipeSep1 :: IParser a -> IParser [a]
175−pipeSep1 =
176− spaceySepBy1 (char '|' <?> "a vertical bar '|'")
177−
178−
179−consSep1 :: IParser a -> IParser [a]
180−consSep1 =
181− spaceySepBy1 (string "::" <?> "a cons operator '::'")
113+{-# INLINE dot #-}
114+dot :: Parser ()
115+dot =
116+ expecting "a dot '.'" $
117+ Prim.text "."
182118
183119
184−dotSep1 :: IParser a -> IParser [a]
185−dotSep1 p =
186− (:) <$> p <*> many (try (char '.') >> p)
120+{-# INLINE underscore #-}
121+underscore :: Parser ()
122+underscore =
123+ expecting "a wildcard '_'" $
124+ Prim.text "_"
187125
188126
189−spaceSep1 :: IParser a -> IParser [a]
190−spaceSep1 p =
191− (:) <$> p <*> spacePrefix p
127+{-# INLINE lambda #-}
128+lambda :: Parser ()
129+lambda =
130+ oneOf [ Prim.text "\\", Prim.text "\x03BB" ]
192131
193132
194−spacePrefix :: IParser a -> IParser [a]
195−spacePrefix p =
196− constrainedSpacePrefix p (\_ -> return ())
197133
134+-- ENCLOSURES
198135
199−constrainedSpacePrefix :: IParser a -> (Bool -> IParser ()) -> IParser [a]
200−constrainedSpacePrefix parser constraint =
201− many $ choice
202− [ try (spacing >> lookAhead (oneOf "[({\"'")) >> parser
203− , try (spacing >> parser)
204− ]
205− where
206− spacing = do
207− bool <- whitespace
208− constraint bool
209− indented
210136
137+{-# INLINE leftParen #-}
138+leftParen :: Parser ()
139+leftParen =
140+ Prim.text "("
211141
212142
213−-- SURROUNDED BY
143+{-# INLINE rightParen #-}
144+rightParen :: Parser ()
145+rightParen =
146+ Prim.text ")"
214147
215148
216−surround :: Char -> Char -> String -> IParser a -> IParser a
217−surround start end name parser =
218− do char start
219− whitespace
220− value <- parser
221− whitespace
222− char end <?> unwords ["a closing", name, show end]
223− return value
149+{-# INLINE leftSquare #-}
150+leftSquare :: Parser ()
151+leftSquare =
152+ Prim.text "["
224153
225154
226−braces :: IParser a -> IParser a
227−braces parser =
228− surround '[' ']' "brace" parser
155+{-# INLINE rightSquare #-}
156+rightSquare :: Parser ()
157+rightSquare =
158+ Prim.text "]"
229159
230160
231−parens :: IParser a -> IParser a
232−parens parser =
233− surround '(' ')' "paren" parser
161+{-# INLINE leftCurly #-}
162+leftCurly :: Parser ()
163+leftCurly =
164+ Prim.text "{"
234165
235166
236−brackets :: IParser a -> IParser a
237−brackets parser =
238− surround '{' '}' "bracket" parser
167+{-# INLINE rightCurly #-}
168+rightCurly :: Parser ()
169+rightCurly =
170+ Prim.text "}"
239171
240172
241173
242−-- HELPERS FOR EXPRESSIONS
243174
244175
245−getMyPosition :: IParser R.Position
246−getMyPosition =
247− R.fromSourcePos <$> getPosition
176+-- LOCATION
248177
249178
250−addLocation :: IParser a -> IParser (A.Located a)
179+addLocation :: Parser a -> Parser (A.Located a)
251180addLocation parser =
252− do start <- getMyPosition
181+ do start <- getPosition
253182 value <- parser
254− end <- getMyPosition
183+ end <- getPosition
255184 return (A.at start end value)
256185
257186
258−located :: IParser a -> IParser (R.Position, a, R.Position)
259−located parser =
260− do start <- getMyPosition
261− value <- parser
262− end <- getMyPosition
263− return (start, value, end)
264−
265−
266−accessible :: IParser Src.RawExpr -> IParser Src.RawExpr
267−accessible exprParser =
268− do start <- getMyPosition
269−
270− annotatedRootExpr@(A.A _ rootExpr) <- exprParser
271187
272− access <- optionMaybe (try dot <?> "a field access like .name")
188+-- WHITESPACE VARIATIONS
273189
274− case access of
275− Nothing ->
276− return annotatedRootExpr
277190
278− Just _ ->
279− accessible $
280− do v <- var
281− end <- getMyPosition
282− return . A.at start end $
283− case rootExpr of
284− Src.Var (Variable.Raw name@(c:_))
285− | isUpper c ->
286− Src.var (name ++ '.' : v)
287− _ ->
288− Src.Access annotatedRootExpr v
289−
290−
291−dot :: IParser ()
292−dot =
293− do char '.'
294− notFollowedBy (char '.')
295−
296−
297−
298−-- WHITESPACE
299−
300−
301−padded :: IParser a -> IParser a
302−padded p =
303− do whitespace
304− out <- p
305− whitespace
306− return out
307−
308−
309−plus :: IParser a -> IParser ()
310−plus parser =
311− parser >> star parser
312−
313−
314−star :: IParser a -> IParser ()
315−star parser =
316− choice
317− [ parser >> star parser
318− , return ()
319− ]
320−
321−
322−spaces :: IParser ()
191+spaces :: Parser ()
323192spaces =
324− plus $ expecting Syntax.whitespace $
325− choice
326− [ string " " >> return ()
327− , multiComment
328− ]
329−
330−
331−forcedWS :: IParser ()
332−forcedWS =
333− do failIfTabFound
334− plus (spaces <|> newline)
335− failIfTabFound
336− column <- sourceColumn <$> getPosition
337− if column == 1
338− then fail badWhiteSpaceMessage
339− else return ()
340−
341−
342−badWhiteSpaceMessage :: String
343−badWhiteSpaceMessage =
344− "I need whitespace, but got stuck on what looks like a new declaration.\n"
345− ++ "\n"
346− ++ "You are either missing some stuff in the declaration above or just need to add\n"
347− ++ "some spaces here:"
348−
349−
350−failIfTabFound :: IParser ()
351−failIfTabFound =
352− do foundTab <- option False (lookAhead (char '\t') >> return True) <?> Syntax.tab
353− if foundTab
354− then fail Syntax.tab
355− else return ()
356−
357−
358−-- Just eats whitespace until the next meaningful character.
359−dumbWhitespace :: IParser ()
360−dumbWhitespace =
361− star (spaces <|> newline)
362−
363−
364−whitespace :: IParser Bool
365−whitespace =
366− choice
367− [ forcedWS >> return True
368− , return False
369− ]
370−
371−
372−freshLine :: IParser ()
373−freshLine =
374− expecting Syntax.freshLine $ try $
375− do plus (spaces <|> newline)
376− column <- sourceColumn <$> getPosition
377− if column == 1
378− then return ()
379− else fail badFreshLineMessage
380−
381−
382−badFreshLineMessage :: String
383−badFreshLineMessage =
384− "I need a fresh line to start a new declaration. This means a new line that\n"
385− ++ "starts with stuff, not with spaces or comments."
386−
387−
388−newline :: IParser ()
389−newline =
390− simpleNewline <|> lineComment <?> Syntax.newline
391−
392−
393−simpleNewline :: IParser ()
394−simpleNewline =
395− do try (string "\r\n") <|> string "\n"
396− return ()
397−
398−
399−lineComment :: IParser ()
400−lineComment =
401− do try (string "--")
402− anyUntil (simpleNewline <|> eof)
403−
404−
405−multiComment :: IParser ()
406−multiComment =
407− do try (string "{-" >> notFollowedBy (string "|"))
408− closeComment
409−
410−
411−closeComment :: IParser ()
412−closeComment =
413− choice
414− [ expecting "the end of a comment -}" $
415− do try (string "-}")
416− return ()
417− , do try (string "{-")
418− closeComment
419− closeComment
420− , do anyChar
421− closeComment
422− ]
423−
193+ do space <- whitespace
194+ case space of
195+ None -> return ()
196+ AfterIndent -> return ()
197+ BeforeIndent -> failure (error "TODO")
198+ Aligned -> failure (error "TODO")
199+ Freshline -> failure (error "TODO")
200+
201+
202+checkSpaces :: Space -> Parser ()
203+checkSpaces space =
204+ case space of
205+ None -> return ()
206+ AfterIndent -> return ()
207+ BeforeIndent -> deadend (error "TODO")
208+ Aligned -> deadend (error "TODO")
209+ Freshline -> deadend (error "TODO")
424210
425−docComment :: IParser String
426−docComment =
427− do try (string "{-|")
428− builder <- closeDocComment id
429− return (builder "")
430−
431−
432−closeDocComment :: (String -> String) -> IParser (String -> String)
433−closeDocComment builder =
434− choice
435− [ expecting "the end of a comment -}" $
436− do try (string "-}")
437− return builder
438− , do try (string "{-")
439− addComment <- closeDocComment (\end -> "{-" ++ end)
440− closeDocComment (\end -> builder (addComment ("-}" ++ end)))
441− , do c <- anyChar
442− closeDocComment (\end -> builder (c:end))
443− ]
src/Parse/Literal.hs+32−195
@@ -1,34 +1,29 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Literal (literal, shader) where
3−
4−import Prelude hiding (exponent)
5−import Control.Monad (join)
6−import qualified Data.Char as Char
7−import qualified Data.List as List
8−import qualified Data.Map as Map
9−import qualified Language.GLSL.Parser as GLP
10−import qualified Language.GLSL.Syntax as GLS
11−import Text.Parsec
12− ( ParseError, (<|>), anyChar, char, choice, digit, getPosition
13− , hexDigit, lookAhead, many1, option, parserFail, satisfy
14− , setPosition, string, try, upper
15− )
2+module Parse.Literal (literal) where
3+
4+--import Prelude hiding (exponent)
5+--import Control.Monad (join)
6+--import qualified Data.Char as Char
7+--import qualified Data.List as List
8+--import qualified Data.Map as Map
9+--import qualified Language.GLSL.Parser as GLP
10+--import qualified Language.GLSL.Syntax as GLS
1611
1712import qualified AST.Literal as L
18−import Parse.Helpers (IParser, expecting, failure)
19−import qualified Reporting.Error.Syntax as Error
13+import Parse.Helpers (Parser, string, character, oneOf)
14+--import qualified Reporting.Error.Syntax as Error
2015
2116
2217
2318-- LITERALS
2419
2520
26−literal :: IParser L.Literal
21+literal :: Parser L.Literal
2722literal =
28− choice
29− [ toLiteral <$> rawNumber
30− , stringLiteral
31− , charLiteral
23+ oneOf
24+ [ L.Str <$> string
25+ , L.Chr <$> character
26+ , number
3227 ]
3328
3429
@@ -36,6 +31,12 @@ literal =
3631-- NUMBERS
3732
3833
34+number :: Parser L.Literal
35+number =
36+ error "TODO"
37+
38+
39+{--
3940toLiteral :: String -> L.Literal
4041toLiteral n
4142 | 'x' `elem` n = L.IntNum (read n)
@@ -43,7 +44,7 @@ toLiteral n
4344 | otherwise = L.IntNum (read n)
4445
4546
46−rawNumber :: IParser String
47+rawNumber :: Parser String
4748rawNumber =
4849 concat <$> sequence
4950 [ option "" minus
@@ -51,14 +52,14 @@ rawNumber =
5152 ]
5253
5354
54−base16 :: IParser String
55+base16 :: Parser String
5556base16 =
5657 do try (string "0x")
5758 digits <- many1 hexDigit
5859 return ("0x" ++ digits)
5960
6061
61−base10 :: IParser String
62+base10 :: Parser String
6263base10 =
6364 concat <$> sequence
6465 [ many1 digit
@@ -67,7 +68,7 @@ base10 =
6768 ]
6869
6970
70−minus :: IParser String
71+minus :: Parser String
7172minus =
7273 try $ do
7374 string "-"
@@ -75,7 +76,7 @@ minus =
7576 return "-"
7677
7778
78−decimals :: IParser String
79+decimals :: Parser String
7980decimals =
8081 do try $ lookAhead (string "." >> digit)
8182 string "."
@@ -83,7 +84,7 @@ decimals =
8384 return ('.' : n)
8485
8586
86−exponent :: IParser String
87+exponent :: Parser String
8788exponent =
8889 do string "e" <|> string "E"
8990 op <- option "" (string "+" <|> string "-")
@@ -92,176 +93,10 @@ exponent =
9293
9394
9495
95−-- CHARACTERS
96−
97−
98−charLiteral :: IParser L.Literal
99−charLiteral =
100− expecting "a character like 'c'" $
101− do start <- getPosition
102− char '\''
103− firstChar <-
104− choice
105− [ char '\\' >> escapeCode
106− , satisfy (\c -> c /= '\'' && c > '\026')
107− ]
108− choice
109− [ do char '\''
110− return (L.Chr firstChar)
111− , do setPosition start
112− failure Error.singleQuotes
113− ]
114−
115−
116−
117−-- STRINGS
118−
119−
120−stringLiteral :: IParser L.Literal
121−stringLiteral =
122− expecting "a string like \"hello\"" $
123− do char '"'
124− choice
125− [ do try (string "\"\"")
126− multiStringClose mempty
127− , do singleStringClose mempty
128− ]
129−
130−
131−singleStringClose :: (String -> String) -> IParser L.Literal
132−singleStringClose builder =
133− choice
134− [ do char '"'
135− return (L.Str (builder ""))
136− , do char '\\'
137− choice
138− [ do char '&'
139− singleStringClose builder
140− , do c <- escapeCode
141− singleStringClose (\end -> builder (c : end))
142− ]
143− , do c <- satisfy (\c -> c > '\026')
144− singleStringClose (\end -> builder (c : end))
145− , failure "Not expecting a character like this in a string."
146− ]
147−
148−
149−multiStringClose :: (String -> String) -> IParser L.Literal
150−multiStringClose builder =
151− choice
152− [ do try (string "\"\"\"")
153− return (L.Str (builder ""))
154− , do char '\n'
155− multiStringClose (\end -> builder ('\n' : end))
156− , do char '\\'
157− choice
158− [ do char '&'
159− multiStringClose builder
160− , do c <- escapeCode
161− multiStringClose (\end -> builder (c : end))
162− ]
163− , do c <- satisfy (\c -> c > '\026')
164− multiStringClose (\end -> builder (c : end))
165− , failure "Not expecting a character like this in a multi-line string."
166− ]
167−
168−
169−escapeCode :: IParser Char
170−escapeCode =
171− choice
172− [ do char '^'
173− code <- upper
174− return (toEnum (fromEnum code - fromEnum 'A' + 1))
175− -- NUMBERS
176− , do parseCode 10 digit
177− , do char 'x'
178− parseCode 16 hexDigit
179− -- ESCAPES
180− , c2c 'a' '\a'
181− , c2c 'b' '\b'
182− , c2c 'f' '\f'
183− , c2c 'n' '\n'
184− , c2c 'r' '\r'
185− , c2c 't' '\t'
186− , c2c 'v' '\v'
187− , c2c '"' '"'
188− , c2c '\\' '\\'
189− , c2c '\'' '\''
190− -- ASCII CODES
191− , s2c "BS" '\BS'
192− , s2c "HT" '\HT'
193− , s2c "LF" '\LF'
194− , s2c "VT" '\VT'
195− , s2c "FF" '\FF'
196− , s2c "CR" '\CR'
197− , s2c "SO" '\SO'
198− , s2c "SI" '\SI'
199− , s2c "EM" '\EM'
200− , s2c "FS" '\FS'
201− , s2c "GS" '\GS'
202− , s2c "RS" '\RS'
203− , s2c "US" '\US'
204− , s2c "SP" '\SP'
205− , s2c "NUL" '\NUL'
206− , s2c "SOH" '\SOH'
207− , s2c "STX" '\STX'
208− , s2c "ETX" '\ETX'
209− , s2c "EOT" '\EOT'
210− , s2c "ENQ" '\ENQ'
211− , s2c "ACK" '\ACK'
212− , s2c "BEL" '\BEL'
213− , s2c "DLE" '\DLE'
214− , s2c "DC1" '\DC1'
215− , s2c "DC2" '\DC2'
216− , s2c "DC3" '\DC3'
217− , s2c "DC4" '\DC4'
218− , s2c "NAK" '\NAK'
219− , s2c "SYN" '\SYN'
220− , s2c "ETB" '\ETB'
221− , s2c "CAN" '\CAN'
222− , s2c "SUB" '\SUB'
223− , s2c "ESC" '\ESC'
224− , s2c "DEL" '\DEL'
225− ]
226−
227−
228−c2c :: Char -> Char -> IParser Char
229−c2c escapedChar resultingChar =
230− do char escapedChar
231− return resultingChar
232−
233−
234−s2c :: String -> Char -> IParser Char
235−s2c escapedString resultingChar =
236− do string escapedString
237− return resultingChar
238−
239−
240−parseCode :: Integer -> IParser Char -> IParser Char
241−parseCode base baseDigit =
242− do start <- getPosition
243− code <- parseNumber base baseDigit
244− if code <= 0x10FFFF
245− then
246− return (toEnum (fromInteger code))
247−
248− else
249− do setPosition start
250− fail "This code is too big! UTF-8 only goes to 10FFFF."
251−
252−
253−parseNumber :: Integer -> IParser Char -> IParser Integer
254−parseNumber base baseDigit =
255− do digits <- many1 baseDigit
256− let n = List.foldl' (\x d -> base * x + toInteger (Char.digitToInt d)) 0 digits
257− seq n (return n)
258−
259−
260−
26196-- SHADERS
26297
26398
264−shader :: IParser (String, L.GLShaderTipe)
99+shader :: Parser (String, L.GLShaderTipe)
265100shader =
266101 do try (string "[glsl|")
267102 rawSrc <- closeShader id
@@ -270,7 +105,7 @@ shader =
270105 Right tipe -> return (rawSrc, tipe)
271106
272107
273−closeShader :: (String -> a) -> IParser a
108+closeShader :: (String -> a) -> Parser a
274109closeShader builder =
275110 choice
276111 [ do try (string "|]")
@@ -330,3 +165,5 @@ glSource src =
330165 GLS.Sampler2D -> return (qual, L.Texture,name)
331166 _ -> []
332167 _ -> []
168+
169+--}
src/Parse/Pattern.hs+177−84
@@ -1,9 +1,9 @@
1−module Parse.Pattern (term, expr) where
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Parse.Pattern (term, expression) where
24
3−import qualified Data.List as List
4−import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, try)
5+import Data.Text (Text)
56
6−import qualified AST.Literal as L
77import qualified AST.Pattern as P
88import qualified AST.Variable as Var
99import Parse.Helpers
@@ -12,102 +12,195 @@ import qualified Reporting.Annotation as A
1212import qualified Reporting.Region as R
1313
1414
15−basic :: IParser P.Raw
16−basic =
17− addLocation $
18− choice
19− [ char '_' >> return P.Anything
20− , P.Var <$> lowVar
21− , chunksToPatterns <$> dotSep1 capVar
22− , P.Literal <$> Literal.literal
23− ]
24− where
25− chunksToPatterns chunks =
26− case List.intercalate "." chunks of
27− "True" ->
28− P.Literal (L.Boolean True)
2915
30− "False" ->
31− P.Literal (L.Boolean False)
16+-- PATTERN TERMS
3217
33− name ->
34− P.Data (Var.Raw name) []
3518
19+term :: Parser P.Raw
20+term =
21+ oneOf [ record, tuple, list, termHelp ]
3622
37−asPattern :: IParser P.Raw -> IParser P.Raw
38−asPattern patternParser =
39− do pattern <- patternParser
4023
41− let (A.A (R.Region start _) _) = pattern
24+termHelp :: Parser P.Raw
25+termHelp =
26+ addLocation $
27+ oneOf
28+ [ do underscore
29+ return P.Anything
30+ , P.Var <$> lowVar
31+ , mkCtor <$> qualifiedCapVar
32+ , P.Literal <$> Literal.literal
33+ ]
4234
43− maybeAlias <- optionMaybe asAlias
4435
45− case maybeAlias of
46− Just alias ->
47− do end <- getMyPosition
48− return (A.at start end (P.Alias alias pattern))
36+mkCtor :: Text -> P.Raw'
37+mkCtor ctor =
38+ P.Ctor (Var.Raw ctor) []
4939
50− Nothing ->
51− return pattern
52− where
53− asAlias =
54− do try (whitespace >> reserved "as")
55− whitespace
56− lowVar
5740
5841
59−record :: IParser P.Raw
60−record =
61− addLocation
62− (P.Record <$> brackets (commaSep1 lowVar))
42+-- RECORDS
6343
6444
65−tuple :: IParser P.Raw
66−tuple =
67− do (start, patterns, end) <-
68− located (parens (commaSep expr))
45+record :: Parser P.Raw
46+record =
47+ addLocation $
48+ do leftCurly
49+ spaces
50+ oneOf
51+ [ do var <- lowVar
52+ spaces
53+ recordHelp [var]
54+ , do rightCurly
55+ return (P.Record [])
56+ ]
6957
70− case patterns of
71− [pattern] ->
72− return pattern
7358
74− _ ->
75− return (A.at start end (P.tuple patterns))
59+recordHelp :: [Text] -> Parser P.Raw'
60+recordHelp vars =
61+ oneOf
62+ [ do comma
63+ spaces
64+ var <- lowVar
65+ spaces
66+ recordHelp (var:vars)
67+ , do rightCurly
68+ return (P.Record vars)
69+ ]
7670
7771
78−list :: IParser P.Raw
79−list =
80− braces $
81− do (_, patterns, end) <- located (commaSep expr)
82− return (P.list end patterns)
8372
73+-- TUPLES
8474
85−term :: IParser P.Raw
86−term =
87− choice [ record, tuple, list, basic ]
88− <?> "a pattern"
8975
90−
91−patternConstructor :: IParser P.Raw
92−patternConstructor =
93− addLocation $
94− do name <- List.intercalate "." <$> dotSep1 capVar
95− case name of
96− "True" ->
97− return $ P.Literal (L.Boolean True)
98−
99− "False" ->
100− return $ P.Literal (L.Boolean False)
101−
102− _ ->
103− P.Data (Var.Raw name) <$> spacePrefix term
104−
105−
106−expr :: IParser P.Raw
107−expr =
108− asPattern subPattern <?> "a pattern"
109− where
110− subPattern =
111− do patterns <- consSep1 (patternConstructor <|> term)
112− end <- getMyPosition
113− return (P.consMany end patterns)
76+tuple :: Parser P.Raw
77+tuple =
78+ do start <- getPosition
79+ leftParen
80+ spaces
81+ oneOf
82+ [ do (pattern, space) <- expression
83+ checkSpaces space
84+ tupleHelp start [pattern]
85+ , do rightParen
86+ end <- getPosition
87+ return (A.at start end (P.tuple []))
88+ ]
89+
90+
91+tupleHelp :: R.Position -> [P.Raw] -> Parser P.Raw
92+tupleHelp start patterns =
93+ oneOf
94+ [ do comma
95+ spaces
96+ (pattern, space) <- expression
97+ checkSpaces space
98+ tupleHelp start (pattern:patterns)
99+ , do rightParen
100+ case patterns of
101+ [pattern] ->
102+ return pattern
103+
104+ _ ->
105+ do end <- getPosition
106+ return (A.at start end (P.tuple (reverse patterns)))
107+ ]
108+
109+
110+
111+-- LIST
112+
113+
114+list :: Parser P.Raw
115+list =
116+ do leftSquare
117+ spaces
118+ oneOf
119+ [ do (pattern, space) <- expression
120+ checkSpaces space
121+ listHelp [pattern]
122+ , do rightSquare
123+ end <- getPosition
124+ return (P.list end [])
125+ ]
126+
127+
128+listHelp :: [P.Raw] -> Parser P.Raw
129+listHelp patterns =
130+ oneOf
131+ [ do comma
132+ spaces
133+ (pattern, space) <- expression
134+ checkSpaces space
135+ listHelp (pattern:patterns)
136+ , do end <- getPosition
137+ rightSquare
138+ return (P.list end (reverse patterns))
139+ ]
140+
141+
142+
143+-- PATTERN EXPRESSION
144+
145+
146+expression :: Parser (P.Raw, Space)
147+expression =
148+ do start <- getPosition
149+ cTerm <- consTerm
150+ exprHelp start [] cTerm
151+
152+
153+consTerm :: Parser (P.Raw, R.Position, Space)
154+consTerm =
155+ oneOf
156+ [ do start <- getPosition
157+ ctor <- qualifiedCapVar
158+ constructorHelp start ctor []
159+ , (,,) <$> term <*> getPosition <*> whitespace
160+ ]
161+
162+
163+exprHelp :: R.Position -> [P.Raw] -> (P.Raw, R.Position, Space) -> Parser (P.Raw, Space)
164+exprHelp start patterns (pattern, end, space) =
165+ oneOf
166+ [ do checkSpaces space
167+ cons
168+ spaces
169+ cTerm <- consTerm
170+ exprHelp start (pattern:patterns) cTerm
171+ , do checkSpaces space
172+ keyword "as"
173+ spaces
174+ alias <- lowVar
175+ newEnd <- getPosition
176+ newSpace <- whitespace
177+ return
178+ ( A.at start newEnd (P.Alias alias (foldl (consHelp end) pattern patterns))
179+ , newSpace
180+ )
181+ , return
182+ ( foldl (consHelp end) pattern patterns
183+ , space
184+ )
185+ ]
186+
187+
188+consHelp :: R.Position -> P.Raw -> P.Raw -> P.Raw
189+consHelp end tl hd@(A.A (R.Region start _) _) =
190+ A.at start end (P.Ctor (Var.Raw "::") [hd, tl])
191+
192+
193+constructorHelp :: R.Position -> Text -> [P.Raw] -> Parser (P.Raw, R.Position, Space)
194+constructorHelp start ctor args =
195+ do end <- getPosition
196+ space <- whitespace
197+ oneOf
198+ [ do checkSpaces space
199+ arg <- term
200+ constructorHelp start ctor (arg:args)
201+ , return
202+ ( A.at start end (P.Ctor (Var.Raw ctor) (reverse args))
203+ , end
204+ , space
205+ )
206+ ]
src/Parse/Primitives.hs+131−22
@@ -1,12 +1,14 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
33module Parse.Primitives
44 ( Parser
55 , run
6− , try, lookAhead, failure, deadend, expecting, endOfFile
6+ , try, failure, deadend, expecting, endOfFile
77 , oneOf
8− , text, lowVar, capVar
9− , getPosition, setIndent
8+ , text, keyword, keywords
9+ , lowVar, capVar, infixOp
10+ , getPosition, getCol
11+ , getIndent, setIndent
1012 , Space(..), whitespace
1113 , string, character
1214 )
@@ -14,6 +16,8 @@ module Parse.Primitives
1416
1517import Prelude hiding (length)
1618import qualified Data.Char as Char
19+import qualified Data.Set as Set
20+import Data.Text (Text)
1721import qualified Data.Text as Text
1822import qualified Data.Text.Array as Text
1923import qualified Data.Text.Internal as Text
@@ -25,6 +29,7 @@ import Data.Text.Internal.Unsafe.Char (unsafeChr)
2529import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
2630import Control.Monad
2731
32+import qualified AST.Helpers as Help (isSymbol)
2833import qualified Reporting.Region as Region
2934
3035
@@ -70,7 +75,7 @@ data Error
7075-- RUN PARSER
7176
7277
73−run :: Parser a -> Text.Text -> Either Error a
78+run :: Parser a -> Text -> Either Error a
7479run parser (Text.Text array offset length) =
7580 case _run parser (State array offset length 0 1 1) Ok Err Ok Err of
7681 Ok value _ ->
@@ -90,13 +95,6 @@ try parser =
9095 _run parser state cok eerr eok eerr
9196
9297
93−lookAhead :: Parser a -> Parser a
94−lookAhead parser =
95− Parser $ \state _ cerr eok eerr ->
96− _run parser state eok cerr eok eerr
97− -- TODO used to mess with error info in ok. Why?
98−
99−
10098failure :: error -> Parser a
10199failure _msg =
102100 Parser $ \(State _ _ _ _ row col) _ cerr _ _ ->
@@ -215,7 +213,7 @@ instance Monad Parser where
215213-- TEXT
216214
217215
218−text :: Text.Text -> Parser ()
216+text :: Text -> Parser ()
219217text (Text.Text tArray tOffset tLen) =
220218 Parser $ \(State array offset length indent row col) cok _ _ eerr ->
221219 if tLen <= length && Text.equal tArray tOffset array offset tLen then
@@ -236,12 +234,12 @@ moveCursor array offset length row col =
236234
237235 else
238236 let
239− !word1 = Text.unsafeIndex array offset
237+ !word = Text.unsafeIndex array offset
240238 in
241− if word1 == 0x000A then
239+ if word == 0x000A then
242240 moveCursor array (offset + 1) (length - 1) (row + 1) 1
243241
244− else if word1 < 0xD800 || word1 > 0xDBFF then
242+ else if word < 0xD800 || word > 0xDBFF then
245243 moveCursor array (offset + 1) (length - 1) row (col + 1)
246244
247245 else
@@ -249,6 +247,42 @@ moveCursor array offset length row col =
249247
250248
251249
250+-- KEYWORDS
251+
252+
253+keyword :: Text -> Parser ()
254+keyword (Text.Text tArray tOffset tLen) =
255+ Parser $ \(State array offset length indent row col) cok _ _ eerr ->
256+ if tLen <= length && Text.equal tArray tOffset array offset tLen then
257+
258+ if Char.isAlphaNum (peekChar array (offset + tLen)) then
259+ eerr (error "TODO keyword 1")
260+ else
261+ let
262+ (# newRow, newCol #) =
263+ moveCursor tArray tOffset tLen row col
264+ in
265+ cok () (State array (offset + tLen) (length - tLen) indent newRow newCol)
266+
267+ else
268+ eerr (error "TODO keyword 2")
269+
270+
271+keywords :: Set.Set Text
272+keywords =
273+ Set.fromList
274+ [ "if", "then", "else"
275+ , "case", "of"
276+ , "let", "in"
277+ , "type"
278+ , "module", "where"
279+ , "import", "exposing"
280+ , "as"
281+ , "port"
282+ ]
283+
284+
285+
252286-- VARIABLES
253287
254288
@@ -289,7 +323,10 @@ varPrim isGoodFirstChar =
289323 copiedText =
290324 Text.Text (Text.run makeArray) 0 newSize
291325 in
292− cok copiedText (State array newOffset newLength indent row newCol)
326+ if Set.member copiedText keywords then
327+ eerr (Error row newCol)
328+ else
329+ cok copiedText (State array newOffset newLength indent row newCol)
293330
294331 else
295332 eerr (error "TODO varPrim 2")
@@ -299,12 +336,24 @@ varPrim isGoodFirstChar =
299336peek :: Text.Array -> Int -> Text.Iter
300337peek array offset =
301338 let
302− !word1 = Text.unsafeIndex array offset
339+ !word = Text.unsafeIndex array offset
303340 in
304− if word1 < 0xD800 || word1 > 0xDBFF then
305− Text.Iter (unsafeChr word1) 1
341+ if word < 0xD800 || word > 0xDBFF then
342+ Text.Iter (unsafeChr word) 1
306343 else
307− Text.Iter (chr2 word1 (Text.unsafeIndex array (offset + 1))) 2
344+ Text.Iter (chr2 word (Text.unsafeIndex array (offset + 1))) 2
345+
346+
347+{-# INLINE peekChar #-}
348+peekChar :: Text.Array -> Int -> Char
349+peekChar array offset =
350+ let
351+ !word = Text.unsafeIndex array offset
352+ in
353+ if word < 0xD800 || word > 0xDBFF then
354+ unsafeChr word
355+ else
356+ chr2 word (Text.unsafeIndex array (offset + 1))
308357
309358
310359varPrimHelp :: Text.Array -> Int -> Int -> Int -> (# Int, Int, Int #)
@@ -324,6 +373,54 @@ varPrimHelp array offset length col =
324373
325374
326375
376+-- INFIX OPS
377+
378+
379+infixOp :: Parser Text
380+infixOp =
381+ Parser $ \(State array offset length indent row col) cok cerr _ eerr ->
382+ if length == 0 then
383+ eerr (Error row col)
384+ else
385+ case infixOpHelp array offset length row col of
386+ Left err ->
387+ cerr err
388+
389+ Right ( newOffset, newLength, newCol ) ->
390+ let
391+ !newSize =
392+ newOffset - offset
393+
394+ makeArray =
395+ do mutableArray <- Text.new newSize
396+ Text.copyI mutableArray 0 array offset newSize
397+ return mutableArray
398+ in
399+ case Text.Text (Text.run makeArray) 0 newSize of
400+ "=" -> cerr (Error row col) -- "The = operator is reserved for defining variables. Maybe you want == instead? Or maybe you are defining a variable, but there is whitespace before it?"
401+ "->" -> cerr (Error row col) -- "Arrows are reserved for cases and anonymous functions. Maybe you want > or >= instead?"
402+ "|" -> cerr (Error row col) -- "Vertical bars are reserved for use in union type declarations. Maybe you want || instead?"
403+ ":" -> cerr (Error row col) -- "A single colon is for type annotations. Maybe you want :: instead? Or maybe you are defining a type annotation, but there is whitespace before it?"
404+ "." -> cerr (Error row col) -- "Dots are for record access. They cannot float around on their own!"
405+ op -> cok op (State array newOffset newLength indent row newCol)
406+
407+
408+infixOpHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either Error (Int, Int, Int)
409+infixOpHelp array offset length row col =
410+ if length == 0 then
411+ Left (Error row col)
412+
413+ else
414+ let
415+ (Text.Iter char size) = peek array offset
416+ in
417+ if Help.isSymbol char then
418+ infixOpHelp array (offset + size) (length - size) row (col + 1)
419+ else
420+ Right ( offset, length, col )
421+
422+
423+
327424-- STATE
328425
329426
@@ -333,6 +430,18 @@ getPosition =
333430 eok (Region.Position row col) state
334431
335432
433+getIndent :: Parser Int
434+getIndent =
435+ Parser $ \state@(State _ _ _ indent _ _) _ _ eok _ ->
436+ eok indent state
437+
438+
439+getCol :: Parser Int
440+getCol =
441+ Parser $ \state@(State _ _ _ _ _ col) _ _ eok _ ->
442+ eok col state
443+
444+
336445setIndent :: Int -> Parser ()
337446setIndent indent =
338447 Parser $ \state _ _ eok _ ->
@@ -349,7 +458,7 @@ data Space
349458 | BeforeIndent
350459 | Aligned
351460 | AfterIndent
352− deriving (Show)
461+ deriving (Eq)
353462
354463
355464whitespace :: Parser Space
src/Parse/Type.hs+165−82
@@ -1,8 +1,8 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Type where
2+{-# LANGUAGE OverloadedStrings #-}
3+module Parse.Type (expression) where
34
4−import Data.List (intercalate)
5−import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, string, try)
5+import Data.Text (Text)
66
77import qualified AST.Type as Type
88import qualified AST.Variable as Var
@@ -11,89 +11,172 @@ import qualified Reporting.Annotation as A
1111import qualified Reporting.Region as R
1212
1313
14−tvar :: IParser Type.Raw
15−tvar =
16− addLocation
17− (Type.RVar <$> lowVar <?> "a type variable")
1814
15+-- TYPE TERMS
1916
20−tuple :: IParser Type.Raw
21−tuple =
22− do (start, types, end) <- located (parens (commaSep expr))
23− case types of
24− [t] -> return t
25− _ -> return (Type.tuple (R.Region start end) types)
2617
18+term :: Parser Type.Raw
19+term =
20+ oneOf
21+ [ constructor
22+ , variable
23+ , tuple
24+ , record
25+ ]
2726
28−record :: IParser Type.Raw
29−record =
30− addLocation $
31− do char '{'
32− whitespace
33− rcrd <- extended <|> normal
34− dumbWhitespace
35− char '}'
36− return rcrd
37− where
38− normal = flip Type.RRecord Nothing <$> commaSep field
39−
40− -- extended record types require at least one field
41− extended =
42− do ext <- try (addLocation lowVar <* (whitespace >> string "|"))
43− whitespace
44− fields <- commaSep1 field
45− return (Type.RRecord fields (Just (A.map Type.RVar ext)))
46−
47− field =
48− do lbl <- addLocation rLabel
49− whitespace >> hasType >> whitespace
50− (,) lbl <$> expr
51−
52−
53−capTypeVar :: IParser String
54−capTypeVar =
55− intercalate "." <$> dotSep1 capVar
56−
57−
58−constructor0 :: IParser Type.Raw
59−constructor0 =
60− addLocation $
61− do name <- capTypeVar
62− return (Type.RType (Var.Raw name))
6327
6428
65−term :: IParser Type.Raw
66−term =
67− choice [ tuple, record, tvar, constructor0 ]
68−
69−
70−app :: IParser Type.Raw
71−app =
72− do start <- getMyPosition
73− f <- constructor0 <?> "a type constructor"
74− args <- spacePrefix term
75− end <- getMyPosition
76− case args of
77− [] -> return f
78− _ -> return (A.A (R.Region start end) (Type.RApp f args))
79−
80−
81−expr :: IParser Type.Raw
82−expr =
83− do start <- getMyPosition
84− t1 <- app <|> term
85− arr <- optionMaybe $ try (whitespace >> rightArrow)
86− case arr of
87− Nothing ->
88− return t1
89− Just _ ->
90− do whitespace
91− t2 <- expr
92− end <- getMyPosition
93− return (A.A (R.Region start end) (Type.RLambda t1 t2))
94−
95−
96−constructor :: IParser (String, [Type.Raw])
29+-- TYPE VARIABLES
30+
31+
32+variable :: Parser Type.Raw
33+variable =
34+ expecting "a type variable" $ addLocation $
35+ Type.RVar <$> lowVar
36+
37+
38+
39+-- TYPE EXPRESSIONS
40+
41+
42+expression :: SParser Type.Raw
43+expression =
44+ do start <- getPosition
45+ (tipe1, end1, space1) <-
46+ oneOf
47+ [ app start
48+ , (,,) <$> term <*> getPosition <*> whitespace
49+ ]
50+ oneOf
51+ [ do checkSpaces space1
52+ rightArrow
53+ spaces
54+ (tipe2, end2, space2) <- expression
55+ let tipe = A.at start end2 (Type.RLambda tipe1 tipe2)
56+ return ( tipe, end2, space2 )
57+ , return ( tipe1, end1, space1 )
58+ ]
59+
60+
61+
62+-- TYPE APPLICATION
63+
64+
65+app :: R.Position -> SParser Type.Raw
66+app start =
67+ do ctor <- constructor
68+ end <- getPosition
69+ space <- whitespace
70+ appHelp ctor [] start end space
71+
72+
73+constructor :: Parser Type.Raw
9774constructor =
98− (,) <$> (capTypeVar <?> "another type constructor")
99− <*> spacePrefix term
75+ expecting "a type constructor, like Maybe or List" $ addLocation $
76+ fmap (Type.RType . Var.Raw) qualifiedCapVar
77+
78+
79+appHelp :: Type.Raw -> [Type.Raw] -> R.Position -> R.Position -> Space -> SParser Type.Raw
80+appHelp ctor args start end space =
81+ oneOf
82+ [ do checkSpaces space
83+ arg <- term
84+ newEnd <- getPosition
85+ newSpace <- whitespace
86+ appHelp ctor (arg:args) start newEnd newSpace
87+ , let
88+ tipe =
89+ if null args then
90+ ctor
91+ else
92+ A.at start end (Type.RApp ctor (reverse args))
93+ in
94+ return ( tipe, end, space )
95+ ]
96+
97+
98+
99+-- TUPLES
100+
101+
102+tuple :: Parser Type.Raw
103+tuple =
104+ do start <- getPosition
105+ leftParen
106+ spaces
107+ tupleEnding start []
108+
109+
110+tupleEnding :: R.Position -> [Type.Raw] -> Parser Type.Raw
111+tupleEnding start tipes =
112+ oneOf
113+ [ do comma
114+ spaces
115+ (tipe, _, space) <- expression
116+ checkSpaces space
117+ tupleEnding start (tipe : tipes)
118+ , do rightParen
119+ end <- getPosition
120+ case reverse tipes of
121+ [tipe] ->
122+ return tipe
123+
124+ tupleTypes ->
125+ return (Type.tuple (R.Region start end) tupleTypes)
126+ ]
127+
128+
129+
130+-- RECORD
131+
132+
133+record :: Parser Type.Raw
134+record =
135+ addLocation $
136+ do leftCurly
137+ spaces
138+ oneOf
139+ [ do rightCurly
140+ return (Type.RRecord [] Nothing)
141+ , do var <- addLocation lowVar
142+ spaces
143+ oneOf
144+ [ do pipe
145+ spaces
146+ firstField <- field
147+ fields <- chompFields [firstField]
148+ return (Type.RRecord fields (Just (A.map Type.RVar var)))
149+ , do hasType
150+ spaces
151+ (tipe, _, nextSpace) <- expression
152+ checkSpaces nextSpace
153+ fields <- chompFields [(var, tipe)]
154+ return (Type.RRecord fields Nothing)
155+ ]
156+ ]
157+
158+
159+type Field = ( A.Located Text, Type.Raw )
160+
161+
162+chompFields :: [Field] -> Parser [Field]
163+chompFields fields =
164+ oneOf
165+ [ do comma
166+ spaces
167+ f <- field
168+ chompFields (f : fields)
169+ , do rightCurly
170+ return fields
171+ ]
172+
173+
174+field :: Parser Field
175+field =
176+ do name <- addLocation lowVar
177+ spaces
178+ hasType
179+ spaces
180+ (tipe, _, endSpace) <- expression
181+ checkSpaces endSpace
182+ return (name, tipe)