git.iko.soy/elk
on master help sign in
Redo parsers for expressions, patterns, types, and literals
b4f1e8bEvan Czaplicki
src/Parse/Expression.hs+429−263
compare with master
unifiedsplit
@@ -1,333 +1,499 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
1−module Parse.Expression (term, expr, def) where
3+module Parse.Expression (term, expression, definition) where
2
4
5+import Control.Monad (guard)
3import qualified Data.List as List
6import qualified Data.List as List
4−import Text.Parsec hiding (newline, spaces)
7+import qualified Data.Text as Text
8+import Data.Text (Text)
5
9
6−import qualified Parse.Binop as Binop
7import Parse.Helpers
10import Parse.Helpers
8−import qualified Parse.Helpers as Help
9import qualified Parse.Literal as Literal
11import qualified Parse.Literal as Literal
10import qualified Parse.Pattern as Pattern
12import qualified Parse.Pattern as Pattern
11import qualified Parse.Type as Type
13import qualified Parse.Type as Type
12
14
13import qualified AST.Expression.Source as Src
15import qualified AST.Expression.Source as Src
14−import qualified AST.Literal as L
15import qualified AST.Pattern as P
16import qualified AST.Pattern as P
16import qualified Reporting.Annotation as A
17import qualified Reporting.Annotation as A
18+import qualified Reporting.Region as R
17
19
18
20
19
21
20−-------- Basic Terms --------
22+-- TERMS
21
23
22
24
23−varTerm :: IParser Src.RawExpr'
25+term :: Parser Src.RawExpr
24−varTerm =
26+term =
25− toVar <$> Help.var
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+ ]
26
39
27
40
28−toVar :: String -> Src.RawExpr'
29−toVar v =
30− case v of
31− "True" ->
32− Src.Literal (L.Boolean True)
33
41
34− "False" ->
42+-- LISTS
35− Src.Literal (L.Boolean False)
36
43
37− _ ->
38− Src.var v
39
44
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+ ]
40
57
41−accessor :: IParser Src.RawExpr'
42−accessor =
43− do start <- getMyPosition
44− label <- try (char '.' >> rLabel)
45− end <- getMyPosition
46
58
47− let ann 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
48− A.at start end value
69+ return (A.at start end (Src.List (reverse entries)))
70+ ]
49
71
50− return $
51− Src.Lambda
52− (ann (P.Var "_"))
53− (ann (Src.Access (ann (Src.var "_")) label))
54
72
55
73
56−negative :: IParser Src.RawExpr'
74+-- TUPLES
57−negative =
58− try $
59− do (A.A region _) <- addLocation (char '-')
60− notFollowedBy (char '.' <|> char '-')
61− negativeTerm <- term
62
75
63− let zero = A.A region (Src.Literal (L.IntNum 0))
64− let minus = A.A region "-"
65
76
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)
67
88
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))
68
95
96+ , do spaces
97+ (entry, _, space) <- expression
98+ checkSpaces space
99+ tupleHelp start [entry]
100+ ]
69
101
70
102
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)
72
106
73
107
74−listTerm :: IParser Src.RawExpr'
108+chompCommas :: Int -> Parser Int
75−listTerm =
109+chompCommas n =
76− choice
110+ oneOf
77− [ do pos <- getPosition
111+ [ comma >> chompCommas (n + 1)
78− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
112+ , return n
79− (rawSrc, tipe) <- Literal.shader
80− return $ Src.GLShader uid (filter (/='\r') rawSrc) tipe
81− , braces (Src.List <$> commaSep expr)
82 ]
113 ]
83
114
84
115
85−parensTerm :: IParser Src.RawExpr
116+tupleHelp :: R.Position -> [Src.RawExpr] -> Parser Src.RawExpr
86−parensTerm =
117+tupleHelp start entries =
87− let
118+ oneOf
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
119+ [ do comma
99− let args = map (('v':) . show) [ 0 .. length commas ]
120+ spaces
100− return $ mkFunc args (\var -> Src.tuple (map var args))
121+ (entry, _, space) <- expression
101−
122+ checkSpaces space
102− parenedExpr =
123+ tupleHelp start (entry:entries)
103− do expressions <- padded (commaSep expr)
124+ , do rightParen
104− return $ \start end ->
125+ end <- getPosition
105− case expressions of
126+ case entries of
106− [expression] ->
127+ [entry] ->
107− expression
128+ return entry
129+
108− _ ->
130+ _ ->
109− A.at start end (Src.tuple expressions)
131+ return (A.at start end (Src.tuple (reverse entries)))
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 [])
134 ]
132 ]
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− ]
154
133
155− field =
156− do key <- addLocation rLabel
157− padded equals
158− value <- expr
159− return (key, value)
160
134
161
135
162−term :: IParser Src.RawExpr
136+-- RECORDS
163−term =
137+
164− choice
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 []))
165− [ addLocation $ choice $
147+ , do starter <- addLocation lowVar
166− [ Src.Literal <$> Literal.literal
148+ spaces
167− , listTerm
149+ oneOf
168− , accessor
150+ [ do pipe
169− , negative
151+ spaces
170− ]
152+ firstField <- chompField
171− , accessible $ choice $
153+ fields <- chompFields [firstField]
172− [ addLocation varTerm
154+ end <- getPosition
173− , parensTerm
155+ return (A.at start end (Src.Update (A.map Src.var starter) fields))
174− , recordTerm
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+ ]
175 ]
164 ]
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
176 ]
179 ]
177− <?> "an expression"
178
180
179
181
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+
180
192
181−-------- Applications --------
182
193
194+-- EXPRESSIONS
183
195
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
194
196
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+ ]
195
214
196
215
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+ ]
198
290
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+ ]
199
311
200−expr :: IParser Src.RawExpr
201−expr =
202− addLocation (choice [ letExpr, caseExpr, ifExpr ])
203− <|> lambdaExpr
204− <|> binaryExpr
205− <?> "an expression"
206
312
207
313
208−binaryExpr :: IParser Src.RawExpr
314+-- IF EXPRESSION
209−binaryExpr =
210− Binop.binops appExpr lastExpr
211− where
212− lastExpr =
213− addLocation (choice [ letExpr, caseExpr, ifExpr ])
214− <|> lambdaExpr
215− <?> "an expression"
216
315
217
316
218−ifExpr :: IParser Src.RawExpr'
317+if_ :: R.Position -> ExprParser
219−ifExpr =
318+if_ start =
220− ifHelp []
319+ ifHelp start []
221
320
222
321
223−ifHelp :: [(Src.RawExpr, Src.RawExpr)] -> IParser Src.RawExpr'
322+ifHelp :: R.Position -> [(Src.RawExpr, Src.RawExpr)] -> ExprParser
224−ifHelp branches =
323+ifHelp start branches =
225− do try (reserved "if")
324+ do keyword "if"
226− whitespace
325+ spaces
227− condition <- expr
326+ (condition, _, condSpace) <- expression
228− padded (reserved "then")
327+ checkSpaces condSpace
328+ keyword "then"
329+ spaces
229− thenBranch <- expr
330+ (thenBranch, _, thenSpace) <- expression
230− whitespace <?> "an 'else' branch"
331+ checkSpaces thenSpace
231− reserved "else" <?> "an 'else' branch"
332+ keyword "else"
232− whitespace
333+ spaces
233 let newBranches = (condition, thenBranch) : branches
334 let newBranches = (condition, thenBranch) : branches
234− choice
335+ oneOf
235− [ ifHelp newBranches
336+ [ ifHelp start newBranches
337+ , do (elseBranch, elseEnd, elseSpace) <- expression
236− , Src.If (reverse newBranches) <$> expr
338+ let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)
339+ return ( ifExpr, elseEnd, elseSpace )
237 ]
340 ]
238
341
239
342
240−lambdaExpr :: IParser Src.RawExpr
343+
241−lambdaExpr =
344+-- LAMBDA EXPRESSION
242− do start <- getMyPosition
345+
243− char '\\' <|> char '\x03BB' <?> "an anonymous function"
346+
244− whitespace
347+function :: R.Position -> ExprParser
348+function start =
349+ do lambda
350+ spaces
245− args <- spaceSep1 Pattern.term
351+ arg <- Pattern.term
246− padded rightArrow
352+ spaces
247− body <- expr
353+ revArgs <- gatherArgs [arg]
248− end <- getMyPosition
354+ spaces
355+ (body, end, space) <- expression
249− return (foldr (\a b -> A.at start end $ Src.Lambda a b) body args)
356+ let func = List.foldl' (\e x -> A.at start end (Src.Lambda x e)) body revArgs
250−
357+ return ( func, end, space )
251−
358+
252−caseExpr :: IParser Src.RawExpr'
359+
253−caseExpr =
360+gatherArgs :: [P.Raw] -> Parser [P.Raw]
254− do try (reserved "case")
361+gatherArgs args =
255− exp <- padded expr
362+ oneOf
256− reserved "of"
363+ [ do arg <- Pattern.term
257− whitespace
364+ spaces
258− Help.withPos $
365+ gatherArgs (arg:args)
259− do firstBranch <- branch
366+ , do rightArrow
260− branches <-
367+ return args
261− many $ do
368+ ]
262− try (whitespace >> Help.checkIndent)
369+
263− branch
370+
264− return $ Src.Case exp (firstBranch : branches)
371+
265− where
372+-- CASE EXPRESSIONS
266− branch =
373+
267− do p <- Pattern.expr
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
268− padded rightArrow
400+ rightArrow
269− (,) p <$> expr
401+ spaces
270−
402+ (branchExpr, end, space) <- expression
271−
403+ return ( (pattern, branchExpr), end, space )
272−
404+
273−-- LET
405+
274−
406+caseHelp :: [(P.Raw, Src.RawExpr)] -> R.Position -> Space -> SParser [(P.Raw, Src.RawExpr)]
275−
407+caseHelp branches end space =
276−letExpr :: IParser Src.RawExpr'
408+ case space of
277−letExpr =
409+ Aligned ->
278− do try (reserved "let")
410+ do (branch, newEnd, newSpace) <- branchHelp
279− whitespace
411+ caseHelp (branch:branches) newEnd newSpace
280− defs <- Help.block (def <* whitespace)
412+
281− whitespace
413+ _ ->
282− reserved "in"
414+ return ( reverse branches, end, space )
283− whitespace
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
284− Src.Let defs <$> expr
449+ let letExpr = A.at start end (Src.Let defs body)
285−
450+ return ( letExpr, newEnd, newSpace )
286−
451+
452+
453+
454+-- DEFINITIONS
455+
456+
287−def :: IParser Src.RawDef
457+definition :: SParser Src.RawDef
288−def =
458+definition =
289− addLocation $ Help.withPos $
290− do start <- defStart
459+ do start <- getPosition
291− whitespace
460+ root <- rootPattern start
292− case start of
461+ spaces
462+ case A.drop root of
293− A.A _ (P.Var name) ->
463+ P.Var name ->
294− choice
464+ oneOf
295− [ do hasType
465+ [ do hasType
296− whitespace
466+ spaces
297− tipe <- Type.expr
467+ (tipe, end, space) <- Type.expression
298− return $ Src.Annotation name tipe
468+ return ( A.at start end (Src.Annotation name tipe), end, space )
299− , defEnd start []
469+ , definitionHelp start root []
300− ]
470+ ]
301−
471+
302− _ ->
472+ _ ->
303− defEnd start []
473+ definitionHelp start root []
304−
474+
305−
475+
306−defStart :: IParser P.Raw
476+rootPattern :: R.Position -> Parser P.Raw
307−defStart =
477+rootPattern start =
308− choice
478+ oneOf
309− [ addLocation $ try $
479+ [ do op <- try (leftParen >> infixOp)
310− do char '('
480+ rightParen
311− op <- Binop.infixOp
481+ end <- getPosition
312− char ')'
313− return (P.Var op)
482+ return (A.at start end (P.Var op))
314 , Pattern.term
483 , Pattern.term
315 ]
484 ]
316
485
317
486
318−defEnd :: P.Raw -> [P.Raw] -> IParser Src.RawDef'
487+definitionHelp :: R.Position -> P.Raw -> [P.Raw] -> SParser Src.RawDef
319−defEnd start revArgs =
488+definitionHelp start root revArgs =
320− choice
489+ oneOf
321 [ do arg <- Pattern.term
490 [ do arg <- Pattern.term
322− whitespace
491+ spaces
323− defEnd start (arg : revArgs)
492+ definitionHelp start root (arg : revArgs)
324 , do equals
493 , do equals
325− whitespace
494+ spaces
326− body <- expr
495+ (expr, end, space) <- expression
327− return $ Src.Definition start (makeFunction revArgs body)
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 )
328 ]
499 ]
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 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module Parse.Helpers
3module Parse.Helpers
3 ( module Parse.Primitives
4 ( module Parse.Primitives
4− , var, lowVar, capVar, rLabel, reserved, reserveds
5+ , SParser
6+ , qualifiedVar, qualifiedCapVar
5− , equals, rightArrow, hasType
7+ , equals, rightArrow, hasType, comma, pipe, cons, dot, underscore, lambda
6− , commitIf, followedBy, anyUntil
8+ , leftParen, rightParen, leftSquare, rightSquare, leftCurly, rightCurly
7− , comma, commaSep1, commaSep
8− , pipeSep1, consSep1, dotSep1, spaceSep1, spacePrefix, constrainedSpacePrefix
9− , braces, parens, brackets
10− , accessible
11− , getMyPosition, addLocation, located
9+ , addLocation
12− , whitespace, freshLine, simpleNewline, newline, spaces
10+ , spaces, checkSpaces
13− , forcedWS, padded, dumbWhitespace, docComment
14 )
11 )
15 where
12 where
16
13
17−import Data.Char (isUpper)
18−import qualified Data.Set as Set
14+import qualified Data.Text as Text
19−import Text.Parsec hiding (newline, space, spaces)
15+import Data.Text (Text)
20
16
21−import qualified AST.Expression.Source as Src
17+import Parse.Primitives hiding (text)
22−import qualified AST.Variable as Variable
18+import qualified Parse.Primitives as Prim
23−import Parse.Primitives
24import qualified Reporting.Annotation as A
19import qualified Reporting.Annotation as A
25−import qualified Reporting.Error.Syntax as Syntax
26import qualified Reporting.Region as R
20import qualified Reporting.Region as R
27
21
28
22
29
23
30−-- VARIABLES
24+-- SPACE PARSER
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"
41
25
42
26
43−capVar :: IParser String
27+type SParser a =
44−capVar =
28+ Parser (a, R.Position, Space)
45− makeVar upper <?> "an upper case name"
46
29
47
30
48−rLabel :: IParser String
49−rLabel =
50− lowVar
51
31
52−
32+-- VARIABLES
53−innerVarChar :: IParser Char
54−innerVarChar =
55− alphaNum <|> char '_' <?> "more letters in this name"
56
33
57
34
58−makeVar :: IParser Char -> IParser String
35+qualifiedCapVar :: Parser Text
59−makeVar firstChar =
36+qualifiedCapVar =
60− do variable <- (:) <$> firstChar <*> many innerVarChar
37+ do var <- capVar
61− choice
38+ qualifiedVarHelp True [var]
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− ]
69
39
70
40
71−reserved :: String -> IParser String
41+qualifiedVar :: Parser Text
72−reserved word =
42+qualifiedVar =
73− expecting ("reserved word `" ++ word ++ "`") $
43+ oneOf
74− do string word
44+ [ lowVar
75− choice
45+ , do var <- capVar
76− [ do lookAhead (char '\'')
46+ qualifiedVarHelp False [var]
77− failure (Syntax.prime word)
78− , do notFollowedBy innerVarChar
79− return word
80− ]
47+ ]
81
48
82
49
83−reserveds :: Set.Set String
50+qualifiedVarHelp :: Bool -> [Text] -> Parser Text
84−reserveds =
51+qualifiedVarHelp allCaps vars =
85− Set.fromList
52+ oneOf
53+ [ do dot
54+ oneOf
55+ [ do var <- capVar
56+ qualifiedVarHelp allCaps (var:vars)
57+ , if allCaps then
58+ failure (error "TODO")
86− [ "if", "then", "else"
59+ else
87− , "case", "of"
60+ do var <- lowVar
88− , "let", "in"
61+ return (Text.intercalate "." (reverse (var:vars)))
89− , "type"
62+ ]
90− , "module", "where"
63+ , return (Text.intercalate "." (reverse vars))
91− , "import", "exposing"
92− , "as"
93− , "port"
94 ]
64 ]
95
65
96
66
@@ -98,346 +68,143 @@ reserveds =
98-- COMMON SYMBOLS
68-- COMMON SYMBOLS
99
69
100
70
101−equals :: IParser String
71+{-# INLINE equals #-}
72+equals :: Parser ()
102equals =
73equals =
103− string "=" <?> "an equals sign '='"
74+ expecting "an equals sign '='" $
75+ Prim.text "="
104
76
105
77
78+{-# INLINE rightArrow #-}
106−rightArrow :: IParser String
79+rightArrow :: Parser ()
107rightArrow =
80rightArrow =
108− string "->" <?> "an arrow '->'"
81+ expecting "an arrow '->'" $
82+ Prim.text "->"
109
83
110
84
85+{-# INLINE hasType #-}
111−hasType :: IParser String
86+hasType :: Parser ()
112hasType =
87hasType =
113− string ":" <?> "the \"has type\" symbol ':'"
88+ expecting "the \"has type\" symbol ':'" $
114−
89+ Prim.text ":"
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−
136
90
137−followedBy :: IParser a -> IParser b -> IParser a
138−followedBy a b =
139− do x <- a
140− b
141− return x
142
91
143−
92+{-# INLINE comma #-}
144−
93+comma :: Parser ()
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
160comma =
94comma =
161− char ',' <?> "a comma ','"
95+ expecting "a comma ','" $
96+ Prim.text ","
162
97
163
98
164−commaSep1 :: IParser a -> IParser [a]
99+{-# INLINE pipe #-}
165−commaSep1 =
100+pipe :: Parser ()
166− spaceySepBy1 comma
101+pipe =
102+ expecting "a vertical bar '|'" $
103+ Prim.text "|"
167
104
168
105
169−commaSep :: IParser a -> IParser [a]
106+{-# INLINE cons #-}
170−commaSep =
107+cons :: Parser ()
171− option [] . commaSep1
108+cons =
109+ expecting "a cons operator '::'" $
110+ Prim.text "::"
172
111
173
112
174−pipeSep1 :: IParser a -> IParser [a]
113+{-# INLINE dot #-}
175−pipeSep1 =
114+dot :: Parser ()
176− spaceySepBy1 (char '|' <?> "a vertical bar '|'")
115+dot =
177−
116+ expecting "a dot '.'" $
178−
117+ Prim.text "."
179−consSep1 :: IParser a -> IParser [a]
180−consSep1 =
181− spaceySepBy1 (string "::" <?> "a cons operator '::'")
182
118
183
119
184−dotSep1 :: IParser a -> IParser [a]
120+{-# INLINE underscore #-}
185−dotSep1 p =
121+underscore :: Parser ()
186− (:) <$> p <*> many (try (char '.') >> p)
122+underscore =
123+ expecting "a wildcard '_'" $
124+ Prim.text "_"
187
125
188
126
189−spaceSep1 :: IParser a -> IParser [a]
127+{-# INLINE lambda #-}
190−spaceSep1 p =
128+lambda :: Parser ()
191− (:) <$> p <*> spacePrefix p
129+lambda =
130+ oneOf [ Prim.text "\\", Prim.text "\x03BB" ]
192
131
193
132
194−spacePrefix :: IParser a -> IParser [a]
195−spacePrefix p =
196− constrainedSpacePrefix p (\_ -> return ())
197
133
134+-- ENCLOSURES
198
135
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
210
136
137+{-# INLINE leftParen #-}
138+leftParen :: Parser ()
139+leftParen =
140+ Prim.text "("
211
141
212
142
213−-- SURROUNDED BY
143+{-# INLINE rightParen #-}
144+rightParen :: Parser ()
145+rightParen =
146+ Prim.text ")"
214
147
215
148
216−surround :: Char -> Char -> String -> IParser a -> IParser a
149+{-# INLINE leftSquare #-}
217−surround start end name parser =
150+leftSquare :: Parser ()
218− do char start
151+leftSquare =
219− whitespace
152+ Prim.text "["
220− value <- parser
221− whitespace
222− char end <?> unwords ["a closing", name, show end]
223− return value
224
153
225
154
226−braces :: IParser a -> IParser a
155+{-# INLINE rightSquare #-}
227−braces parser =
156+rightSquare :: Parser ()
228− surround '[' ']' "brace" parser
157+rightSquare =
158+ Prim.text "]"
229
159
230
160
231−parens :: IParser a -> IParser a
161+{-# INLINE leftCurly #-}
232−parens parser =
162+leftCurly :: Parser ()
233− surround '(' ')' "paren" parser
163+leftCurly =
164+ Prim.text "{"
234
165
235
166
236−brackets :: IParser a -> IParser a
167+{-# INLINE rightCurly #-}
237−brackets parser =
168+rightCurly :: Parser ()
238− surround '{' '}' "bracket" parser
169+rightCurly =
170+ Prim.text "}"
239
171
240
172
241
173
242−-- HELPERS FOR EXPRESSIONS
243
174
244
175
245−getMyPosition :: IParser R.Position
176+-- LOCATION
246−getMyPosition =
247− R.fromSourcePos <$> getPosition
248
177
249
178
250−addLocation :: IParser a -> IParser (A.Located a)
179+addLocation :: Parser a -> Parser (A.Located a)
251addLocation parser =
180addLocation parser =
252− do start <- getMyPosition
181+ do start <- getPosition
253 value <- parser
182 value <- parser
254− end <- getMyPosition
183+ end <- getPosition
255 return (A.at start end value)
184 return (A.at start end value)
256
185
257
186
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
271
187
272− access <- optionMaybe (try dot <?> "a field access like .name")
188+-- WHITESPACE VARIATIONS
273
189
274− case access of
275− Nothing ->
276− return annotatedRootExpr
277
190
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 ()
323spaces =
192spaces =
324− plus $ expecting Syntax.whitespace $
193+ do space <- whitespace
325− choice
194+ case space of
326− [ string " " >> return ()
195+ None -> 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 ()
196+ AfterIndent -> return ()
397−
197+ BeforeIndent -> failure (error "TODO")
398−
198+ Aligned -> failure (error "TODO")
399−lineComment :: IParser ()
199+ Freshline -> failure (error "TODO")
400−lineComment =
200+
401− do try (string "--")
201+
402− anyUntil (simpleNewline <|> eof)
202+checkSpaces :: Space -> Parser ()
403−
203+checkSpaces space =
404−
204+ case space of
405−multiComment :: IParser ()
205+ None -> return ()
406−multiComment =
206+ AfterIndent -> return ()
407− do try (string "{-" >> notFollowedBy (string "|"))
207+ BeforeIndent -> deadend (error "TODO")
408− closeComment
208+ Aligned -> deadend (error "TODO")
409−
209+ Freshline -> deadend (error "TODO")
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−
424
210
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 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Literal (literal, shader) where
2+module Parse.Literal (literal) where
3−
3+
4−import Prelude hiding (exponent)
4+--import Prelude hiding (exponent)
5−import Control.Monad (join)
5+--import Control.Monad (join)
6−import qualified Data.Char as Char
6+--import qualified Data.Char as Char
7−import qualified Data.List as List
7+--import qualified Data.List as List
8−import qualified Data.Map as Map
8+--import qualified Data.Map as Map
9−import qualified Language.GLSL.Parser as GLP
9+--import qualified Language.GLSL.Parser as GLP
10−import qualified Language.GLSL.Syntax as GLS
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− )
16
11
17import qualified AST.Literal as L
12import qualified AST.Literal as L
18−import Parse.Helpers (IParser, expecting, failure)
13+import Parse.Helpers (Parser, string, character, oneOf)
19−import qualified Reporting.Error.Syntax as Error
14+--import qualified Reporting.Error.Syntax as Error
20
15
21
16
22
17
23-- LITERALS
18-- LITERALS
24
19
25
20
26−literal :: IParser L.Literal
21+literal :: Parser L.Literal
27literal =
22literal =
28− choice
23+ oneOf
29− [ toLiteral <$> rawNumber
24+ [ L.Str <$> string
30− , stringLiteral
25+ , L.Chr <$> character
31− , charLiteral
26+ , number
32 ]
27 ]
33
28
34
29
@@ -36,6 +31,12 @@ literal =
36-- NUMBERS
31-- NUMBERS
37
32
38
33
34+number :: Parser L.Literal
35+number =
36+ error "TODO"
37+
38+
39+{--
39toLiteral :: String -> L.Literal
40toLiteral :: String -> L.Literal
40toLiteral n
41toLiteral n
41 | 'x' `elem` n = L.IntNum (read n)
42 | 'x' `elem` n = L.IntNum (read n)
@@ -43,7 +44,7 @@ toLiteral n
43 | otherwise = L.IntNum (read n)
44 | otherwise = L.IntNum (read n)
44
45
45
46
46−rawNumber :: IParser String
47+rawNumber :: Parser String
47rawNumber =
48rawNumber =
48 concat <$> sequence
49 concat <$> sequence
49 [ option "" minus
50 [ option "" minus
@@ -51,14 +52,14 @@ rawNumber =
51 ]
52 ]
52
53
53
54
54−base16 :: IParser String
55+base16 :: Parser String
55base16 =
56base16 =
56 do try (string "0x")
57 do try (string "0x")
57 digits <- many1 hexDigit
58 digits <- many1 hexDigit
58 return ("0x" ++ digits)
59 return ("0x" ++ digits)
59
60
60
61
61−base10 :: IParser String
62+base10 :: Parser String
62base10 =
63base10 =
63 concat <$> sequence
64 concat <$> sequence
64 [ many1 digit
65 [ many1 digit
@@ -67,7 +68,7 @@ base10 =
67 ]
68 ]
68
69
69
70
70−minus :: IParser String
71+minus :: Parser String
71minus =
72minus =
72 try $ do
73 try $ do
73 string "-"
74 string "-"
@@ -75,7 +76,7 @@ minus =
75 return "-"
76 return "-"
76
77
77
78
78−decimals :: IParser String
79+decimals :: Parser String
79decimals =
80decimals =
80 do try $ lookAhead (string "." >> digit)
81 do try $ lookAhead (string "." >> digit)
81 string "."
82 string "."
@@ -83,7 +84,7 @@ decimals =
83 return ('.' : n)
84 return ('.' : n)
84
85
85
86
86−exponent :: IParser String
87+exponent :: Parser String
87exponent =
88exponent =
88 do string "e" <|> string "E"
89 do string "e" <|> string "E"
89 op <- option "" (string "+" <|> string "-")
90 op <- option "" (string "+" <|> string "-")
@@ -92,176 +93,10 @@ exponent =
92
93
93
94
94
95
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−
261-- SHADERS
96-- SHADERS
262
97
263
98
264−shader :: IParser (String, L.GLShaderTipe)
99+shader :: Parser (String, L.GLShaderTipe)
265shader =
100shader =
266 do try (string "[glsl|")
101 do try (string "[glsl|")
267 rawSrc <- closeShader id
102 rawSrc <- closeShader id
@@ -270,7 +105,7 @@ shader =
270 Right tipe -> return (rawSrc, tipe)
105 Right tipe -> return (rawSrc, tipe)
271
106
272
107
273−closeShader :: (String -> a) -> IParser a
108+closeShader :: (String -> a) -> Parser a
274closeShader builder =
109closeShader builder =
275 choice
110 choice
276 [ do try (string "|]")
111 [ do try (string "|]")
@@ -330,3 +165,5 @@ glSource src =
330 GLS.Sampler2D -> return (qual, L.Texture,name)
165 GLS.Sampler2D -> return (qual, L.Texture,name)
331 _ -> []
166 _ -> []
332 _ -> []
167 _ -> []
168+
169+--}
src/Parse/Pattern.hs+177−84
@@ -1,9 +1,9 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
1−module Parse.Pattern (term, expr) where
3+module Parse.Pattern (term, expression) where
2
4
3−import qualified Data.List as List
5+import Data.Text (Text)
4−import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, try)
5
6
6−import qualified AST.Literal as L
7import qualified AST.Pattern as P
7import qualified AST.Pattern as P
8import qualified AST.Variable as Var
8import qualified AST.Variable as Var
9import Parse.Helpers
9import Parse.Helpers
@@ -12,102 +12,195 @@ import qualified Reporting.Annotation as A
12import qualified Reporting.Region as R
12import qualified Reporting.Region as R
13
13
14
14
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)
29
15
30− "False" ->
16+-- PATTERN TERMS
31− P.Literal (L.Boolean False)
32
17
33− name ->
34− P.Data (Var.Raw name) []
35
18
19+term :: Parser P.Raw
20+term =
21+ oneOf [ record, tuple, list, termHelp ]
36
22
37−asPattern :: IParser P.Raw -> IParser P.Raw
38−asPattern patternParser =
39− do pattern <- patternParser
40
23
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+ ]
42
34
43− maybeAlias <- optionMaybe asAlias
44
35
45− case maybeAlias of
36+mkCtor :: Text -> P.Raw'
46− Just alias ->
37+mkCtor ctor =
47− do end <- getMyPosition
38+ P.Ctor (Var.Raw ctor) []
48− return (A.at start end (P.Alias alias pattern))
49
39
50− Nothing ->
51− return pattern
52− where
53− asAlias =
54− do try (whitespace >> reserved "as")
55− whitespace
56− lowVar
57
40
58
41
59−record :: IParser P.Raw
42+-- RECORDS
60−record =
61− addLocation
62− (P.Record <$> brackets (commaSep1 lowVar))
63
43
64
44
65−tuple :: IParser P.Raw
45+record :: Parser P.Raw
66−tuple =
46+record =
67− do (start, patterns, end) <-
47+ addLocation $
68− located (parens (commaSep expr))
48+ do leftCurly
49+ spaces
50+ oneOf
51+ [ do var <- lowVar
52+ spaces
53+ recordHelp [var]
54+ , do rightCurly
55+ return (P.Record [])
56+ ]
69
57
70− case patterns of
71− [pattern] ->
72− return pattern
73
58
74− _ ->
59+recordHelp :: [Text] -> Parser P.Raw'
75− return (A.at start end (P.tuple patterns))
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+ ]
76
70
77
71
78−list :: IParser P.Raw
79−list =
80− braces $
81− do (_, patterns, end) <- located (commaSep expr)
82− return (P.list end patterns)
83
72
73+-- TUPLES
84
74
85−term :: IParser P.Raw
86−term =
87− choice [ record, tuple, list, basic ]
88− <?> "a pattern"
89
75
90−
76+tuple :: Parser P.Raw
91−patternConstructor :: IParser P.Raw
77+tuple =
92−patternConstructor =
78+ do start <- getPosition
93− addLocation $
79+ leftParen
94− do name <- List.intercalate "." <$> dotSep1 capVar
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
95− case name of
100+ case patterns of
96− "True" ->
101+ [pattern] ->
97− return $ P.Literal (L.Boolean True)
102+ return pattern
98−
103+
99− "False" ->
104+ _ ->
100− return $ P.Literal (L.Boolean False)
105+ do end <- getPosition
101−
106+ return (A.at start end (P.tuple (reverse patterns)))
102− _ ->
107+ ]
103− P.Data (Var.Raw name) <$> spacePrefix term
108+
104−
109+
105−
110+
106−expr :: IParser P.Raw
111+-- LIST
107−expr =
112+
108− asPattern subPattern <?> "a pattern"
113+
109− where
114+list :: Parser P.Raw
110− subPattern =
115+list =
111− do patterns <- consSep1 (patternConstructor <|> term)
116+ do leftSquare
112− end <- getMyPosition
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
113− return (P.consMany end patterns)
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 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
3module Parse.Primitives
3module Parse.Primitives
4 ( Parser
4 ( Parser
5 , run
5 , run
6− , try, lookAhead, failure, deadend, expecting, endOfFile
6+ , try, failure, deadend, expecting, endOfFile
7 , oneOf
7 , oneOf
8+ , text, keyword, keywords
8− , text, lowVar, capVar
9+ , lowVar, capVar, infixOp
9− , getPosition, setIndent
10+ , getPosition, getCol
11+ , getIndent, setIndent
10 , Space(..), whitespace
12 , Space(..), whitespace
11 , string, character
13 , string, character
12 )
14 )
@@ -14,6 +16,8 @@ module Parse.Primitives
14
16
15import Prelude hiding (length)
17import Prelude hiding (length)
16import qualified Data.Char as Char
18import qualified Data.Char as Char
19+import qualified Data.Set as Set
20+import Data.Text (Text)
17import qualified Data.Text as Text
21import qualified Data.Text as Text
18import qualified Data.Text.Array as Text
22import qualified Data.Text.Array as Text
19import qualified Data.Text.Internal as Text
23import qualified Data.Text.Internal as Text
@@ -25,6 +29,7 @@ import Data.Text.Internal.Unsafe.Char (unsafeChr)
25import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
29import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
26import Control.Monad
30import Control.Monad
27
31
32+import qualified AST.Helpers as Help (isSymbol)
28import qualified Reporting.Region as Region
33import qualified Reporting.Region as Region
29
34
30
35
@@ -70,7 +75,7 @@ data Error
70-- RUN PARSER
75-- RUN PARSER
71
76
72
77
73−run :: Parser a -> Text.Text -> Either Error a
78+run :: Parser a -> Text -> Either Error a
74run parser (Text.Text array offset length) =
79run parser (Text.Text array offset length) =
75 case _run parser (State array offset length 0 1 1) Ok Err Ok Err of
80 case _run parser (State array offset length 0 1 1) Ok Err Ok Err of
76 Ok value _ ->
81 Ok value _ ->
@@ -90,13 +95,6 @@ try parser =
90 _run parser state cok eerr eok eerr
95 _run parser state cok eerr eok eerr
91
96
92
97
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−
100failure :: error -> Parser a
98failure :: error -> Parser a
101failure _msg =
99failure _msg =
102 Parser $ \(State _ _ _ _ row col) _ cerr _ _ ->
100 Parser $ \(State _ _ _ _ row col) _ cerr _ _ ->
@@ -215,7 +213,7 @@ instance Monad Parser where
215-- TEXT
213-- TEXT
216
214
217
215
218−text :: Text.Text -> Parser ()
216+text :: Text -> Parser ()
219text (Text.Text tArray tOffset tLen) =
217text (Text.Text tArray tOffset tLen) =
220 Parser $ \(State array offset length indent row col) cok _ _ eerr ->
218 Parser $ \(State array offset length indent row col) cok _ _ eerr ->
221 if tLen <= length && Text.equal tArray tOffset array offset tLen then
219 if tLen <= length && Text.equal tArray tOffset array offset tLen then
@@ -236,12 +234,12 @@ moveCursor array offset length row col =
236
234
237 else
235 else
238 let
236 let
239− !word1 = Text.unsafeIndex array offset
237+ !word = Text.unsafeIndex array offset
240 in
238 in
241− if word1 == 0x000A then
239+ if word == 0x000A then
242 moveCursor array (offset + 1) (length - 1) (row + 1) 1
240 moveCursor array (offset + 1) (length - 1) (row + 1) 1
243
241
244− else if word1 < 0xD800 || word1 > 0xDBFF then
242+ else if word < 0xD800 || word > 0xDBFF then
245 moveCursor array (offset + 1) (length - 1) row (col + 1)
243 moveCursor array (offset + 1) (length - 1) row (col + 1)
246
244
247 else
245 else
@@ -249,6 +247,42 @@ moveCursor array offset length row col =
249
247
250
248
251
249
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+
252-- VARIABLES
286-- VARIABLES
253
287
254
288
@@ -289,7 +323,10 @@ varPrim isGoodFirstChar =
289 copiedText =
323 copiedText =
290 Text.Text (Text.run makeArray) 0 newSize
324 Text.Text (Text.run makeArray) 0 newSize
291 in
325 in
326+ if Set.member copiedText keywords then
327+ eerr (Error row newCol)
328+ else
292− cok copiedText (State array newOffset newLength indent row newCol)
329+ cok copiedText (State array newOffset newLength indent row newCol)
293
330
294 else
331 else
295 eerr (error "TODO varPrim 2")
332 eerr (error "TODO varPrim 2")
@@ -299,12 +336,24 @@ varPrim isGoodFirstChar =
299peek :: Text.Array -> Int -> Text.Iter
336peek :: Text.Array -> Int -> Text.Iter
300peek array offset =
337peek array offset =
301 let
338 let
302− !word1 = Text.unsafeIndex array offset
339+ !word = Text.unsafeIndex array offset
303 in
340 in
304− if word1 < 0xD800 || word1 > 0xDBFF then
341+ if word < 0xD800 || word > 0xDBFF then
305− Text.Iter (unsafeChr word1) 1
342+ Text.Iter (unsafeChr word) 1
306 else
343 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))
308
357
309
358
310varPrimHelp :: Text.Array -> Int -> Int -> Int -> (# Int, Int, Int #)
359varPrimHelp :: Text.Array -> Int -> Int -> Int -> (# Int, Int, Int #)
@@ -324,6 +373,54 @@ varPrimHelp array offset length col =
324
373
325
374
326
375
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+
327-- STATE
424-- STATE
328
425
329
426
@@ -333,6 +430,18 @@ getPosition =
333 eok (Region.Position row col) state
430 eok (Region.Position row col) state
334
431
335
432
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+
336setIndent :: Int -> Parser ()
445setIndent :: Int -> Parser ()
337setIndent indent =
446setIndent indent =
338 Parser $ \state _ _ eok _ ->
447 Parser $ \state _ _ eok _ ->
@@ -349,7 +458,7 @@ data Space
349 | BeforeIndent
458 | BeforeIndent
350 | Aligned
459 | Aligned
351 | AfterIndent
460 | AfterIndent
352− deriving (Show)
461+ deriving (Eq)
353
462
354
463
355whitespace :: Parser Space
464whitespace :: Parser Space
src/Parse/Type.hs+165−82
@@ -1,8 +1,8 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−module Parse.Type where
3+module Parse.Type (expression) where
3
4
4−import Data.List (intercalate)
5+import Data.Text (Text)
5−import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, string, try)
6
6
7import qualified AST.Type as Type
7import qualified AST.Type as Type
8import qualified AST.Variable as Var
8import qualified AST.Variable as Var
@@ -11,89 +11,172 @@ import qualified Reporting.Annotation as A
11import qualified Reporting.Region as R
11import qualified Reporting.Region as R
12
12
13
13
14−tvar :: IParser Type.Raw
15−tvar =
16− addLocation
17− (Type.RVar <$> lowVar <?> "a type variable")
18
14
15+-- TYPE TERMS
19
16
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)
26
17
18+term :: Parser Type.Raw
19+term =
20+ oneOf
21+ [ constructor
22+ , variable
23+ , tuple
24+ , record
25+ ]
27
26
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))
63
27
64
28
65−term :: IParser Type.Raw
29+-- TYPE VARIABLES
66−term =
30+
67− choice [ tuple, record, tvar, constructor0 ]
31+
68−
32+variable :: Parser Type.Raw
69−
33+variable =
70−app :: IParser Type.Raw
34+ expecting "a type variable" $ addLocation $
71−app =
35+ Type.RVar <$> lowVar
72− do start <- getMyPosition
36+
73− f <- constructor0 <?> "a type constructor"
37+
74− args <- spacePrefix term
38+
75− end <- getMyPosition
39+-- TYPE EXPRESSIONS
76− case args of
40+
77− [] -> return f
41+
78− _ -> return (A.A (R.Region start end) (Type.RApp f args))
42+expression :: SParser Type.Raw
79−
43+expression =
80−
44+ do start <- getPosition
81−expr :: IParser Type.Raw
45+ (tipe1, end1, space1) <-
82−expr =
46+ oneOf
83− do start <- getMyPosition
47+ [ app start
84− t1 <- app <|> term
48+ , (,,) <$> term <*> getPosition <*> whitespace
49+ ]
50+ oneOf
51+ [ do checkSpaces space1
85− arr <- optionMaybe $ try (whitespace >> rightArrow)
52+ rightArrow
86− case arr of
53+ spaces
87− Nothing ->
54+ (tipe2, end2, space2) <- expression
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))
55+ let tipe = A.at start end2 (Type.RLambda tipe1 tipe2)
94−
56+ return ( tipe, end2, space2 )
95−
57+ , return ( tipe1, end1, space1 )
96−constructor :: IParser (String, [Type.Raw])
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
97constructor =
74constructor =
98− (,) <$> (capTypeVar <?> "another type constructor")
75+ expecting "a type constructor, like Maybe or List" $ addLocation $
99− <*> spacePrefix term
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)