git.iko.soy/elk
on dc356df help sign in
elk/src/Parse/Pattern.hs
272 lines 7.0 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Pattern
4 ( term
5 , expression
6 )
7 where
10import qualified Data.List as List
12import qualified AST.Source as Src
13import qualified Elm.Name as N
14import Parse.Primitives (Parser, SParser, SPos, addLocation, checkSpace, getPosition, hint, inContext, spaces, oneOf)
15import qualified Parse.Primitives.Keyword as Keyword
16import qualified Parse.Primitives.Number as Number
17import qualified Parse.Primitives.Symbol as Symbol
18import qualified Parse.Primitives.Utf8 as Utf8
19import qualified Parse.Primitives.Variable as Var
20import Parse.Primitives.Whitespace (whitespace)
21import qualified Reporting.Annotation as A
22import qualified Reporting.Error.Syntax as E
23import qualified Reporting.Region as R
27-- TERM
30term :: Parser Src.Pattern
31term =
32 hint E.Pattern $
33 do start <- getPosition
34 oneOf
35 [ record start
36 , tuple start
37 , list start
38 , termHelp start
39 ]
42termHelp :: R.Position -> Parser Src.Pattern
43termHelp start =
44 oneOf
45 [
46 do Symbol.underscore
47 end <- getPosition
48 return (A.at start end Src.PAnything)
49 ,
50 do name <- Var.lower
51 end <- getPosition
52 return (A.at start end (Src.PVar name))
53 ,
54 do upper <- Var.foreignUpper
55 end <- getPosition
56 let region = R.Region start end
57 return $ A.at start end $
58 case upper of
59 Var.Unqualified name ->
60 Src.PCtor region name []
62 Var.Qualified home name ->
63 Src.PCtorQual region home name []
64 ,
65 do number <- Number.number
66 end <- getPosition
67 case number of
68 Number.Int int ->
69 return (A.at start end (Src.PInt int))
71 Number.Float _ ->
72 error "TODO floats are not allowed in pattern matches"
73 ,
74 do str <- Utf8.string
75 end <- getPosition
76 return (A.at start end (Src.PStr str))
77 ,
78 do chr <- Utf8.character
79 end <- getPosition
80 return (A.at start end (Src.PChr chr))
81 ]
87-- RECORDS
90record :: R.Position -> Parser Src.Pattern
91record start =
92 do Symbol.leftCurly
93 inContext start E.ExprRecord $
94 do spaces
95 oneOf
96 [ do var <- addLocation Var.lower
97 spaces
98 recordHelp start [var]
99 , do Symbol.rightCurly
100 end <- getPosition
101 return (A.at start end (Src.PRecord []))
102 ]
105recordHelp :: R.Position -> [A.Located N.Name] -> Parser Src.Pattern
106recordHelp start vars =
107 oneOf
108 [ do Symbol.comma
109 spaces
110 var <- addLocation Var.lower
111 spaces
112 recordHelp start (var:vars)
113 , do Symbol.rightCurly
114 end <- getPosition
115 return (A.at start end (Src.PRecord vars))
116 ]
120-- TUPLES
123tuple :: R.Position -> Parser Src.Pattern
124tuple start =
125 do Symbol.leftParen
126 inContext start E.ExprTuple $
127 do spaces
128 oneOf
129 [ do (pattern, sPos) <- expression
130 checkSpace sPos
131 tupleHelp start pattern []
132 , do Symbol.rightParen
133 end <- getPosition
134 return (A.at start end Src.PUnit)
135 ]
138tupleHelp :: R.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern
139tupleHelp start firstPattern revPatterns =
140 oneOf
141 [ do Symbol.comma
142 spaces
143 (pattern, sPos) <- expression
144 checkSpace sPos
145 tupleHelp start firstPattern (pattern : revPatterns)
146 , do Symbol.rightParen
147 case reverse revPatterns of
148 [] ->
149 return firstPattern
151 secondPattern : otherPatterns ->
152 do end <- getPosition
153 return (A.at start end (Src.PTuple firstPattern secondPattern otherPatterns))
154 ]
158-- LIST
161list :: R.Position -> Parser Src.Pattern
162list start =
163 do Symbol.leftSquare
164 inContext start E.PatternList $
165 do spaces
166 oneOf
167 [ do (pattern, sPos) <- expression
168 checkSpace sPos
169 listHelp start [pattern]
170 , do Symbol.rightSquare
171 end <- getPosition
172 return (A.at start end (Src.PList []))
173 ]
176listHelp :: R.Position -> [Src.Pattern] -> Parser Src.Pattern
177listHelp start patterns =
178 oneOf
179 [ do Symbol.comma
180 spaces
181 (pattern, sPos) <- expression
182 checkSpace sPos
183 listHelp start (pattern:patterns)
184 , do Symbol.rightSquare
185 end <- getPosition
186 return (A.at start end (Src.PList (reverse patterns)))
187 ]
191-- EXPRESSION
194expression :: Parser (Src.Pattern, SPos)
195expression =
196 hint E.Pattern $
197 do start <- getPosition
198 cTerm <- exprTerm
199 exprHelp start [] cTerm
202exprHelp :: R.Position -> [Src.Pattern] -> (Src.Pattern, R.Position, SPos) -> Parser (Src.Pattern, SPos)
203exprHelp start patterns (pattern, _end, sPos) =
204 oneOf
205 [ do checkSpace sPos
206 Symbol.cons
207 spaces
208 cTerm <- exprTerm
209 exprHelp start (pattern:patterns) cTerm
210 , do checkSpace sPos
211 Keyword.as_
212 spaces
213 nameStart <- getPosition
214 name <- Var.lower
215 newEnd <- getPosition
216 newSpace <- whitespace
217 let alias = A.at nameStart newEnd name
218 return
219 ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern patterns) alias)
220 , newSpace
221 )
222 , return
223 ( List.foldl' cons pattern patterns
224 , sPos
225 )
226 ]
229cons :: Src.Pattern -> Src.Pattern -> Src.Pattern
230cons tl@(A.At (R.Region _ end) _) hd@(A.At (R.Region start _) _) =
231 A.at start end (Src.PCons hd tl)
235-- EXPRESSION TERM
238exprTerm :: SParser Src.Pattern
239exprTerm =
240 oneOf
241 [
242 do start <- getPosition
243 upper <- Var.foreignUpper
244 end <- getPosition
245 exprTermHelp (R.Region start end) upper start []
246 ,
247 do t@(A.At (R.Region _ end) _) <- term
248 pos <- whitespace
249 return (t, end, pos)
250 ]
253exprTermHelp :: R.Region -> Var.Upper -> R.Position -> [Src.Pattern] -> SParser Src.Pattern
254exprTermHelp region upper start revArgs =
255 do end <- getPosition
256 sPos <- whitespace
257 oneOf
258 [ do checkSpace sPos
259 arg <- term
260 exprTermHelp region upper start (arg:revArgs)
261 , return
262 ( A.at start end $
263 case upper of
264 Var.Unqualified name ->
265 Src.PCtor region name (reverse revArgs)
267 Var.Qualified home name ->
268 Src.PCtorQual region home name (reverse revArgs)
269 , end
270 , sPos
271 )
272 ]