git.iko.soy/elk
on ca2be8a help sign in
elk/src/Parse/Pattern.hs
273 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 as P
16import qualified Parse.Primitives.Keyword as Keyword
17import qualified Parse.Primitives.Number as Number
18import qualified Parse.Primitives.Symbol as Symbol
19import qualified Parse.Primitives.Utf8 as Utf8
20import qualified Parse.Primitives.Variable as Var
21import Parse.Primitives.Whitespace (whitespace)
22import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Syntax as E
24import qualified Reporting.Region as R
28-- TERM
31term :: Parser Src.Pattern
32term =
33 hint E.Pattern $
34 do start <- getPosition
35 oneOf
36 [ record start
37 , tuple start
38 , list start
39 , termHelp start
40 ]
43termHelp :: R.Position -> Parser Src.Pattern
44termHelp start =
45 oneOf
46 [
47 do Symbol.underscore
48 end <- getPosition
49 return (A.at start end Src.PAnything)
50 ,
51 do name <- Var.lower
52 end <- getPosition
53 return (A.at start end (Src.PVar name))
54 ,
55 do upper <- Var.foreignUpper
56 end <- getPosition
57 let region = R.Region start end
58 return $ A.at start end $
59 case upper of
60 Var.Unqualified name ->
61 Src.PCtor region name []
63 Var.Qualified home name ->
64 Src.PCtorQual region home name []
65 ,
66 do number <- Number.number
67 end <- getPosition
68 case number of
69 Number.Int int ->
70 return (A.at start end (Src.PInt int))
72 Number.Float _ ->
73 P.noFloatsAllowedInPatterns
74 ,
75 do str <- Utf8.string
76 end <- getPosition
77 return (A.at start end (Src.PStr str))
78 ,
79 do chr <- Utf8.character
80 end <- getPosition
81 return (A.at start end (Src.PChr chr))
82 ]
88-- RECORDS
91record :: R.Position -> Parser Src.Pattern
92record start =
93 do Symbol.leftCurly
94 inContext start E.ExprRecord $
95 do spaces
96 oneOf
97 [ do var <- addLocation Var.lower
98 spaces
99 recordHelp start [var]
100 , do Symbol.rightCurly
101 end <- getPosition
102 return (A.at start end (Src.PRecord []))
103 ]
106recordHelp :: R.Position -> [A.Located N.Name] -> Parser Src.Pattern
107recordHelp start vars =
108 oneOf
109 [ do Symbol.comma
110 spaces
111 var <- addLocation Var.lower
112 spaces
113 recordHelp start (var:vars)
114 , do Symbol.rightCurly
115 end <- getPosition
116 return (A.at start end (Src.PRecord vars))
117 ]
121-- TUPLES
124tuple :: R.Position -> Parser Src.Pattern
125tuple start =
126 do Symbol.leftParen
127 inContext start E.ExprTuple $
128 do spaces
129 oneOf
130 [ do (pattern, sPos) <- expression
131 checkSpace sPos
132 tupleHelp start pattern []
133 , do Symbol.rightParen
134 end <- getPosition
135 return (A.at start end Src.PUnit)
136 ]
139tupleHelp :: R.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern
140tupleHelp start firstPattern revPatterns =
141 oneOf
142 [ do Symbol.comma
143 spaces
144 (pattern, sPos) <- expression
145 checkSpace sPos
146 tupleHelp start firstPattern (pattern : revPatterns)
147 , do Symbol.rightParen
148 case reverse revPatterns of
149 [] ->
150 return firstPattern
152 secondPattern : otherPatterns ->
153 do end <- getPosition
154 return (A.at start end (Src.PTuple firstPattern secondPattern otherPatterns))
155 ]
159-- LIST
162list :: R.Position -> Parser Src.Pattern
163list start =
164 do Symbol.leftSquare
165 inContext start E.PatternList $
166 do spaces
167 oneOf
168 [ do (pattern, sPos) <- expression
169 checkSpace sPos
170 listHelp start [pattern]
171 , do Symbol.rightSquare
172 end <- getPosition
173 return (A.at start end (Src.PList []))
174 ]
177listHelp :: R.Position -> [Src.Pattern] -> Parser Src.Pattern
178listHelp start patterns =
179 oneOf
180 [ do Symbol.comma
181 spaces
182 (pattern, sPos) <- expression
183 checkSpace sPos
184 listHelp start (pattern:patterns)
185 , do Symbol.rightSquare
186 end <- getPosition
187 return (A.at start end (Src.PList (reverse patterns)))
188 ]
192-- EXPRESSION
195expression :: Parser (Src.Pattern, SPos)
196expression =
197 hint E.Pattern $
198 do start <- getPosition
199 cTerm <- exprTerm
200 exprHelp start [] cTerm
203exprHelp :: R.Position -> [Src.Pattern] -> (Src.Pattern, R.Position, SPos) -> Parser (Src.Pattern, SPos)
204exprHelp start patterns (pattern, _end, sPos) =
205 oneOf
206 [ do checkSpace sPos
207 Symbol.cons
208 spaces
209 cTerm <- exprTerm
210 exprHelp start (pattern:patterns) cTerm
211 , do checkSpace sPos
212 Keyword.as_
213 spaces
214 nameStart <- getPosition
215 name <- Var.lower
216 newEnd <- getPosition
217 newSpace <- whitespace
218 let alias = A.at nameStart newEnd name
219 return
220 ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern patterns) alias)
221 , newSpace
222 )
223 , return
224 ( List.foldl' cons pattern patterns
225 , sPos
226 )
227 ]
230cons :: Src.Pattern -> Src.Pattern -> Src.Pattern
231cons tl@(A.At (R.Region _ end) _) hd@(A.At (R.Region start _) _) =
232 A.at start end (Src.PCons hd tl)
236-- EXPRESSION TERM
239exprTerm :: SParser Src.Pattern
240exprTerm =
241 oneOf
242 [
243 do start <- getPosition
244 upper <- Var.foreignUpper
245 end <- getPosition
246 exprTermHelp (R.Region start end) upper start []
247 ,
248 do t@(A.At (R.Region _ end) _) <- term
249 pos <- whitespace
250 return (t, end, pos)
251 ]
254exprTermHelp :: R.Region -> Var.Upper -> R.Position -> [Src.Pattern] -> SParser Src.Pattern
255exprTermHelp region upper start revArgs =
256 do end <- getPosition
257 sPos <- whitespace
258 oneOf
259 [ do checkSpace sPos
260 arg <- term
261 exprTermHelp region upper start (arg:revArgs)
262 , return
263 ( A.at start end $
264 case upper of
265 Var.Unqualified name ->
266 Src.PCtor region name (reverse revArgs)
268 Var.Qualified home name ->
269 Src.PCtorQual region home name (reverse revArgs)
270 , end
271 , sPos
272 )
273 ]