git.iko.soy/elk
on c19392f help sign in
elk/src/Parse/Pattern.hs
242 lines 5.8 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
11import Data.Text (Text)
13import qualified AST.Literal as L
14import qualified AST.Pattern as P
15import qualified Parse.Literal as Literal
16import Parse.Primitives (Parser, SParser, SPos, checkSpace, getPosition, hint, inContext, spaces, oneOf)
17import qualified Parse.Primitives.Keyword as Keyword
18import qualified Parse.Primitives.Symbol as Symbol
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 P.Raw
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 P.Raw
43termHelp start =
44 do pattern <-
45 oneOf
46 [ Symbol.underscore >> return P.RAnything
47 , P.RVar <$> Var.lower
48 , upperTerm <$> Var.foreignUpper
49 , P.RLiteral <$> Literal.literal
50 ]
51 end <- getPosition
52 return (A.at start end pattern)
55upperTerm :: (Maybe Text, Text) -> P.Raw_
56upperTerm pair =
57 case pair of
58 (Nothing, "True") ->
59 P.RLiteral (L.Boolean True)
61 (Nothing, "False") ->
62 P.RLiteral (L.Boolean False)
64 (maybePrefix, name) ->
65 P.RCtor maybePrefix name []
69-- RECORDS
72record :: R.Position -> Parser P.Raw
73record start =
74 do Symbol.leftCurly
75 inContext start E.ExprRecord $
76 do spaces
77 oneOf
78 [ do var <- Var.lower
79 spaces
80 recordHelp start [var]
81 , do Symbol.rightCurly
82 end <- getPosition
83 return (A.at start end (P.RRecord []))
84 ]
87recordHelp :: R.Position -> [Text] -> Parser P.Raw
88recordHelp start vars =
89 oneOf
90 [ do Symbol.comma
91 spaces
92 var <- Var.lower
93 spaces
94 recordHelp start (var:vars)
95 , do Symbol.rightCurly
96 end <- getPosition
97 return (A.at start end (P.RRecord vars))
98 ]
102-- TUPLES
105tuple :: R.Position -> Parser P.Raw
106tuple start =
107 do Symbol.leftParen
108 inContext start E.ExprTuple $
109 do spaces
110 oneOf
111 [ do (pattern, sPos) <- expression
112 checkSpace sPos
113 tupleHelp start pattern []
114 , do Symbol.rightParen
115 end <- getPosition
116 return (A.at start end P.RUnit)
117 ]
120tupleHelp :: R.Position -> P.Raw -> [P.Raw] -> Parser P.Raw
121tupleHelp start firstPattern revPatterns =
122 oneOf
123 [ do Symbol.comma
124 spaces
125 (pattern, sPos) <- expression
126 checkSpace sPos
127 tupleHelp start firstPattern (pattern : revPatterns)
128 , do Symbol.rightParen
129 case reverse revPatterns of
130 [] ->
131 return firstPattern
133 secondPattern : otherPatterns ->
134 do end <- getPosition
135 return (A.at start end (P.RTuple firstPattern secondPattern otherPatterns))
136 ]
140-- LIST
143list :: R.Position -> Parser P.Raw
144list start =
145 do Symbol.leftSquare
146 inContext start E.PatternList $
147 do spaces
148 oneOf
149 [ do (pattern, sPos) <- expression
150 checkSpace sPos
151 listHelp start [pattern]
152 , do Symbol.rightSquare
153 end <- getPosition
154 return (A.at start end (P.RList []))
155 ]
158listHelp :: R.Position -> [P.Raw] -> Parser P.Raw
159listHelp start patterns =
160 oneOf
161 [ do Symbol.comma
162 spaces
163 (pattern, sPos) <- expression
164 checkSpace sPos
165 listHelp start (pattern:patterns)
166 , do Symbol.rightSquare
167 end <- getPosition
168 return (A.at start end (P.RList (reverse patterns)))
169 ]
173-- EXPRESSION
176expression :: Parser (P.Raw, SPos)
177expression =
178 hint E.Pattern $
179 do start <- getPosition
180 cTerm <- exprTerm
181 exprHelp start [] cTerm
184exprHelp :: R.Position -> [P.Raw] -> (P.Raw, R.Position, SPos) -> Parser (P.Raw, SPos)
185exprHelp start patterns (pattern, _end, sPos) =
186 oneOf
187 [ do checkSpace sPos
188 Symbol.cons
189 spaces
190 cTerm <- exprTerm
191 exprHelp start (pattern:patterns) cTerm
192 , do checkSpace sPos
193 Keyword.as_
194 spaces
195 alias <- Var.lower
196 newEnd <- getPosition
197 newSpace <- whitespace
198 return
199 ( A.at start newEnd (P.RAlias alias (List.foldl' cons pattern patterns))
200 , newSpace
201 )
202 , return
203 ( List.foldl' cons pattern patterns
204 , sPos
205 )
206 ]
209cons :: P.Raw -> P.Raw -> P.Raw
210cons tl@(A.A (R.Region _ end) _) hd@(A.A (R.Region start _) _) =
211 A.at start end (P.RCons hd tl)
215-- EXPRESSION TERM
218exprTerm :: SParser P.Raw
219exprTerm =
220 oneOf
221 [ do start <- getPosition
222 pair <- Var.foreignUpper
223 exprTermHelp start pair []
225 , (,,) <$> term <*> getPosition <*> whitespace
226 ]
229exprTermHelp :: R.Position -> (Maybe Text, Text) -> [P.Raw] -> SParser P.Raw
230exprTermHelp start pair@(prefix, name) args =
231 do end <- getPosition
232 sPos <- whitespace
233 oneOf
234 [ do checkSpace sPos
235 arg <- term
236 exprTermHelp start pair (arg:args)
237 , return
238 ( A.at start end (P.RCtor prefix name (reverse args))
239 , end
240 , sPos
241 )
242 ]