never executed always true always false
1 {-# LANGUAGE TypeFamilies #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# OPTIONS_GHC -Wno-orphans #-}
4 module ElmFormat.AST.PublicAST.Pattern (Pattern(..), mkListPattern) where
5
6 import ElmFormat.AST.PublicAST.Core
7 import ElmFormat.AST.PublicAST.Reference
8 import qualified AST.V0_16 as AST
9 import qualified Data.Either as Either
10 import qualified ElmFormat.AST.PublicAST.Core as Core
11
12
13 data Pattern
14 = AnythingPattern
15 | UnitPattern
16 | LiteralPattern LiteralValue
17 | VariablePattern VariableDefinition
18 | DataPattern
19 { constructor :: Reference
20 , arguments :: List (LocatedIfRequested Pattern) -- Non-empty
21 }
22 | TuplePattern
23 { terms :: List (LocatedIfRequested Pattern) -- At least two items
24 }
25 | ListPattern -- Construct with mkListPattern
26 { prefix :: List (LocatedIfRequested Pattern)
27 , rest :: Maybe (LocatedIfRequested Pattern) -- Must not be a ListPattern
28 }
29 | RecordPattern
30 { fields :: List VariableDefinition
31 }
32 | PatternAlias
33 { alias :: VariableDefinition
34 , pattern :: LocatedIfRequested Pattern
35 }
36
37 mkListPattern :: List (LocatedIfRequested Pattern) -> Maybe (LocatedIfRequested Pattern) -> Pattern
38 mkListPattern prefix rest =
39 case fmap extract rest of
40 Just (ListPattern prefix2 rest2) ->
41 ListPattern (prefix ++ prefix2) rest2
42
43 _ ->
44 ListPattern prefix rest
45
46 instance ToPublicAST 'PatternNK where
47 type PublicAST 'PatternNK = Pattern
48
49 fromRawAST' config = \case
50 AST.Anything ->
51 AnythingPattern
52
53 AST.UnitPattern comments ->
54 UnitPattern
55
56 AST.LiteralPattern lit ->
57 LiteralPattern lit
58
59 AST.VarPattern name ->
60 VariablePattern $ VariableDefinition name
61
62 AST.OpPattern _ ->
63 error "PublicAST: OpPattern is not supported in Elm 0.19"
64
65 AST.DataPattern (namespace, tag) args ->
66 DataPattern
67 (mkReference $ TagRef namespace tag)
68 (fromRawAST config . (\(C comments a) -> a) <$> args)
69
70 AST.PatternParens (C (pre, post) pat) ->
71 extract $ fromRawAST config pat
72
73 AST.TuplePattern terms ->
74 TuplePattern
75 (fromRawAST config . (\(C (c1, c2) a) -> a) <$> terms)
76
77 AST.EmptyListPattern comments ->
78 mkListPattern [] Nothing
79
80 AST.ListPattern terms ->
81 mkListPattern
82 (fmap (fromRawAST config . (\(C comments a) -> a)) terms)
83 Nothing
84
85 AST.ConsPattern (C firstEol first) rest ->
86 let
87 first' = fromRawAST config first
88 rest' = fmap (fromRawAST config . (\(C comments a) -> a)) (AST.toCommentedList rest)
89 in
90 case reverse rest' of
91 [] -> mkListPattern [] (Just first')
92 last : mid -> mkListPattern (first' : reverse mid) (Just last)
93
94 AST.EmptyRecordPattern comment ->
95 RecordPattern []
96
97 AST.RecordPattern fields ->
98 RecordPattern
99 (VariableDefinition . (\(C comments a) -> a) <$> fields)
100
101 AST.Alias (C comments1 pat) (C comments2 name) ->
102 PatternAlias
103 (VariableDefinition name)
104 (fromRawAST config pat)
105
106 instance FromPublicAST 'PatternNK where
107 toRawAST' = \case
108 AnythingPattern ->
109 AST.Anything
110
111 UnitPattern ->
112 AST.UnitPattern []
113
114 LiteralPattern lit ->
115 AST.LiteralPattern lit
116
117 VariablePattern (VariableDefinition name) ->
118 AST.VarPattern name
119
120 DataPattern constructor arguments ->
121 case toRef constructor of
122 TagRef ns tag ->
123 AST.DataPattern
124 (ns, tag)
125 (C [] . toRawAST <$> arguments)
126
127 ref ->
128 error ("invalid DataPattern constructor: " <> show ref)
129
130 TuplePattern terms ->
131 AST.TuplePattern
132 (C ([], []) . toRawAST <$> terms)
133
134 ListPattern [] Nothing ->
135 AST.EmptyListPattern []
136
137 ListPattern some Nothing ->
138 AST.ListPattern
139 (C ([], []) . toRawAST <$> some)
140
141 ListPattern prefix (Just rest) ->
142 done $ foldr step (toRawAST rest, []) (toRawAST <$> prefix)
143 where
144 step next (first, rest) =
145 (next, first : rest)
146
147 done (first, rest) =
148 AST.ConsPattern
149 (C Nothing first)
150 (Either.fromRight undefined $ AST.fromCommentedList $ C ([], [], Nothing) <$> rest)
151
152 RecordPattern [] ->
153 AST.EmptyRecordPattern []
154
155 RecordPattern some ->
156 AST.RecordPattern
157 (C ([], []) . Core.name <$> some)
158
159 PatternAlias alias pattern ->
160 AST.Alias
161 (C [] $ toRawAST pattern)
162 (C [] $ Core.name alias)
163
164
165 instance ToJSON Pattern where
166 toJSON = undefined
167 toEncoding = pairs . toPairs
168
169 instance ToPairs Pattern where
170 toPairs = \case
171 AnythingPattern ->
172 mconcat
173 [ type_ "AnythingPattern"
174 ]
175
176 UnitPattern ->
177 mconcat
178 [ type_ "UnitPattern"
179 ]
180
181 LiteralPattern lit ->
182 toPairs lit
183
184 VariablePattern def ->
185 toPairs def
186
187 DataPattern constructor arguments ->
188 mconcat
189 [ type_ "DataPattern"
190 , "constructor" .= constructor
191 , "arguments" .= arguments
192 ]
193
194 TuplePattern terms ->
195 mconcat
196 [ type_ "TuplePattern"
197 , "terms" .= terms
198 ]
199
200 ListPattern prefix rest ->
201 mconcat
202 [ type_ "ListPattern"
203 , "prefix" .= prefix
204 , "rest" .= rest
205 ]
206
207 RecordPattern fields ->
208 mconcat
209 [ type_ "RecordPattern"
210 , "fields" .= fields
211 ]
212
213 PatternAlias alias pat ->
214 mconcat
215 [ type_ "PatternAlias"
216 , "alias" .= alias
217 , "pattern" .= pat
218 ]
219
220 instance FromJSON Pattern where
221 parseJSON = withObject "Pattern" $ \obj -> do
222 tag <- obj .: "tag"
223 case tag of
224 "AnythingPattern" ->
225 return AnythingPattern
226
227 "UnitPattern" ->
228 return UnitPattern
229
230 "IntLiteral" ->
231 LiteralPattern <$> parseJSON (Object obj)
232
233 "FloatLiteral" ->
234 LiteralPattern <$> parseJSON (Object obj)
235
236 "StringLiteral" ->
237 LiteralPattern <$> parseJSON (Object obj)
238
239 "CharLiteral" ->
240 LiteralPattern <$> parseJSON (Object obj)
241
242 "VariableDefinition" ->
243 VariablePattern <$> parseJSON (Object obj)
244
245 "DataPattern" ->
246 DataPattern
247 <$> obj .: "constructor"
248 <*> obj .: "arguments"
249
250 "TuplePattern" ->
251 TuplePattern
252 <$> obj .: "terms"
253
254 "ListPattern" ->
255 ListPattern
256 <$> obj .: "prefix"
257 <*> obj .: "rest"
258
259 "RecordPattern" ->
260 RecordPattern
261 <$> obj .: "fields"
262
263 "PatternAlias" ->
264 PatternAlias
265 <$> obj .: "alias"
266 <*> obj .: "pattern"
267
268 _ ->
269 fail ("unexpected Pattern tag: " <> tag)