never executed always true always false
1 {-# LANGUAGE TupleSections #-}
2 {-# LANGUAGE KindSignatures #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE DeriveGeneric #-}
6 {-# OPTIONS_GHC -Wno-orphans #-}
7 module ElmFormat.AST.PublicAST.Core
8 ( module Data.Functor.Identity
9 , module Data.Aeson
10 , module Data.Aeson.Encoding.Internal
11 , module GHC.Generics
12 , module ElmFormat.AST.Shared
13 , module AST.V0_16
14 , module AST.Structure
15 , module Reporting.Annotation
16 , module Reporting.Region
17 , module Data.Coapplicative
18 , module ElmFormat.AST.PublicAST.MaybeF
19 , module ElmFormat.AST.PublicAST.Config
20 , ToPairs(..)
21 , ToMaybeJSON(..)
22 , type_
23 , LocatedIfRequested(..)
24 , ModuleName(..)
25 , FromPublicAST(..)
26 , ToPublicAST(..)
27 , VariableDefinition(..)
28 , RecordDisplay(..)
29 ,fromLocated,fromRawAST,toRawAST, noRegion) where
30
31 import Data.Functor.Identity
32 import Data.Aeson
33 import Data.Aeson.Encoding.Internal (pair)
34 import GHC.Generics
35 import ElmFormat.AST.Shared
36 import AST.V0_16 (NodeKind(..), Pair(..))
37 import AST.Structure (ASTNS, ASTNS1, mapNs)
38 import qualified AST.V0_16 as AST
39 import qualified AST.Module as AST
40 import qualified AST.Listing as AST
41 import Data.Indexed as I
42 import Reporting.Annotation (Located(A))
43 import qualified Reporting.Annotation
44 import Reporting.Region (Region)
45 import qualified Reporting.Region as Region
46 import Data.Coapplicative
47 import qualified Data.List as List
48 import qualified Data.Text as Text
49 import qualified Data.Aeson.Encoding.Internal as AesonInternal
50 import qualified Data.Char as Char
51 import Data.Text (Text)
52 import qualified Data.Map.Strict as Map
53 import ElmFormat.AST.PublicAST.Config (Config)
54 import qualified ElmFormat.AST.PublicAST.Config as Config
55 import ElmFormat.AST.PublicAST.MaybeF
56 import qualified Data.Aeson as Aeson
57 import Data.Int (Int64)
58
59
60 class ToPairs a where
61 toPairs :: a -> Series
62
63
64 class ToMaybeJSON a where
65 toMaybeEncoding :: a -> Maybe Encoding
66
67
68 type_ :: String -> Series
69 type_ t =
70 "tag" .= t
71
72
73 class ToPublicAST (nk :: NodeKind) where
74 type PublicAST nk
75 fromRawAST' :: Config -> ASTNS1 Located [UppercaseIdentifier] nk -> PublicAST nk
76
77 fromRawAST :: ToPublicAST nk => Config -> ASTNS Located [UppercaseIdentifier] nk -> LocatedIfRequested (PublicAST nk)
78 fromRawAST config =
79 fmap (fromRawAST' config) . fromLocated config . I.unFix
80
81
82 class ToPublicAST nk => FromPublicAST (nk :: NodeKind) where
83 toRawAST' :: PublicAST nk -> ASTNS1 Identity [UppercaseIdentifier] nk
84
85 toRawAST :: FromPublicAST nk => LocatedIfRequested (PublicAST nk) -> ASTNS Identity [UppercaseIdentifier] nk
86 toRawAST =
87 I.Fix . Identity . toRawAST' . extract
88
89
90 --
91 -- Common types
92 --
93
94
95 newtype ModuleName =
96 ModuleName [UppercaseIdentifier]
97 deriving (Eq, Ord)
98
99 instance Show ModuleName where
100 show (ModuleName ns) = List.intercalate "." $ fmap (\(UppercaseIdentifier v) -> v) ns
101
102 instance ToJSON ModuleName where
103 toJSON = undefined
104 toEncoding (ModuleName []) = toEncoding Null
105 toEncoding namespace = toEncoding $ show namespace
106
107 instance ToJSONKey ModuleName where
108 toJSONKey =
109 ToJSONKeyText
110 (Text.pack . show)
111 (AesonInternal.string . show)
112
113 instance FromJSON ModuleName where
114 parseJSON = withText "ModuleName" $
115 return . ModuleName . fmap (UppercaseIdentifier . Text.unpack) . Text.splitOn "."
116
117 instance FromJSONKey ModuleName where
118 fromJSONKey = FromJSONKeyText (ModuleName . fmap (UppercaseIdentifier . Text.unpack) . Text.splitOn ".")
119
120
121 newtype VariableDefinition
122 = VariableDefinition
123 { name :: LowercaseIdentifier
124 }
125
126 instance ToJSON VariableDefinition where
127 toJSON = undefined
128 toEncoding = pairs . toPairs
129
130 instance ToPairs VariableDefinition where
131 toPairs (VariableDefinition name) =
132 mconcat
133 [ type_ "VariableDefinition"
134 , "name" .= name
135 ]
136
137 instance FromJSON VariableDefinition where
138 parseJSON = withObject "VariableDefinition" $ \obj -> do
139 VariableDefinition
140 <$> obj .: "name"
141
142
143 newtype RecordDisplay
144 = RecordDisplay
145 { fieldOrder :: List LowercaseIdentifier
146 }
147 deriving (Generic)
148
149 instance ToJSON RecordDisplay where
150 toEncoding = genericToEncoding defaultOptions
151
152
153 newtype LocatedIfRequested a
154 = LocatedIfRequested (MaybeF Located a)
155 deriving (Functor)
156
157 instance Coapplicative LocatedIfRequested where
158 extract (LocatedIfRequested a) = extract a
159
160 instance Prelude.Foldable LocatedIfRequested where
161 foldMap f (LocatedIfRequested a) = Prelude.foldMap f a
162
163 instance Traversable LocatedIfRequested where
164 traverse f (LocatedIfRequested a) =
165 LocatedIfRequested <$> traverse f a
166
167 fromLocated :: Config -> Located a -> LocatedIfRequested a
168 fromLocated config la =
169 if Config.showSourceLocation config
170 then LocatedIfRequested $ JustF la
171 else LocatedIfRequested $ NothingF $ extract la
172
173 instance (ToPairs a, ToJSON a) => ToJSON (LocatedIfRequested a) where
174 toJSON = undefined
175 toEncoding = \case
176 LocatedIfRequested (JustF la) -> toEncoding la
177 LocatedIfRequested (NothingF a) -> toEncoding a
178
179 instance (FromJSON a) => FromJSON (LocatedIfRequested a) where
180 parseJSON json =
181 LocatedIfRequested . NothingF <$> parseJSON json
182
183
184
185 --
186 -- Instances for types defined elsewhere
187 --
188
189
190 instance ToPairs a => ToJSON (Located a) where
191 toJSON = undefined
192 toEncoding (A region a) =
193 pairs (toPairs a <> "sourceLocation" .= region)
194
195
196 instance ToJSON Region where
197 toJSON = undefined
198 toEncoding region =
199 pairs $ mconcat
200 [ "start" .= Region.start region
201 , "end" .= Region.end region
202 ]
203
204
205 instance ToJSON Region.Position where
206 toJSON = undefined
207 toEncoding pos =
208 pairs $ mconcat
209 [ "line" .= Region.line pos
210 , "col" .= Region.column pos
211 ]
212
213
214 instance ToJSON UppercaseIdentifier where
215 toJSON = undefined
216 toEncoding (UppercaseIdentifier name) = toEncoding name
217
218 instance FromJSON UppercaseIdentifier where
219 parseJSON = withText "UppercaseIdentifier" $ \case
220 -- XXX: shouldn't crash on empty string
221 text | Char.isUpper $ Text.head text ->
222 return $ UppercaseIdentifier $ Text.unpack text
223
224 _ ->
225 fail "expected a string starting with an uppercase letter"
226 instance FromJSONKey UppercaseIdentifier where
227 fromJSONKey = FromJSONKeyText (UppercaseIdentifier . Text.unpack)
228
229
230 instance ToJSON LowercaseIdentifier where
231 toJSON = undefined
232 toEncoding (LowercaseIdentifier name) = toEncoding name
233 instance ToJSONKey LowercaseIdentifier where
234 toJSONKey =
235 ToJSONKeyText
236 (\(LowercaseIdentifier name) -> Text.pack name)
237 (\(LowercaseIdentifier name) -> AesonInternal.string name)
238
239 instance FromJSON LowercaseIdentifier where
240 parseJSON = withText "LowercaseIdentifier" $ \case
241 -- XXX: shouldn't crash on empty string
242 text | Char.isLower $ Text.head text ->
243 return $ LowercaseIdentifier $ Text.unpack text
244
245 _ ->
246 fail "expected a string starting with a lowercase letter"
247 instance FromJSONKey LowercaseIdentifier where
248 fromJSONKey = FromJSONKeyText (LowercaseIdentifier . Text.unpack)
249
250
251 instance ToJSON SymbolIdentifier where
252 toJSON = undefined
253 toEncoding (SymbolIdentifier sym) = toEncoding sym
254
255
256 instance ToJSON (Ref ()) where
257 toJSON = undefined
258 toEncoding (VarRef () var) = toEncoding var
259 toEncoding (TagRef () tag) = toEncoding tag
260 toEncoding (OpRef sym) = toEncoding sym
261
262
263 instance ToJSON AST.UnaryOperator where
264 toJSON = undefined
265 toEncoding Negative = toEncoding ("-" :: Text)
266
267 instance FromJSON AST.UnaryOperator where
268 parseJSON = withText "UnaryOperator" $ \case
269 "-" -> return AST.Negative
270 other -> fail ("unexpected UnaryOperator (\"-\" is the only valid one): " <> show other)
271
272
273 instance ToJSON (AST.Listing AST.DetailedListing) where
274 toJSON = undefined
275 toEncoding = \case
276 AST.ExplicitListing a multiline -> toEncoding a
277 AST.OpenListing (C comments ()) -> toEncoding ("Everything" :: Text)
278 AST.ClosedListing -> toEncoding Null
279
280 instance FromJSON (AST.Listing AST.DetailedListing) where
281 parseJSON = \case
282 Aeson.String "Everything" ->
283 return $ AST.OpenListing (C ([], []) ())
284
285 Aeson.Bool True ->
286 return $ AST.OpenListing (C ([], []) ())
287
288 Aeson.Null ->
289 return AST.ClosedListing
290
291 Aeson.Bool False ->
292 return AST.ClosedListing
293
294 json ->
295 AST.ExplicitListing
296 <$> parseJSON json
297 <*> return False
298
299
300 instance ToJSON AST.DetailedListing where
301 toJSON = undefined
302 toEncoding = \case
303 AST.DetailedListing values operators types ->
304 pairs $ mconcat
305 [ "values" .= Map.fromList (fmap (\(LowercaseIdentifier k) -> (k, True)) (Map.keys values))
306 , "types" .= Map.fromList (fmap (\(UppercaseIdentifier k, C _ (C _ listing)) -> (k, listing)) (Map.toList types))
307 ]
308
309 instance FromJSON AST.DetailedListing where
310 parseJSON = withObject "DetailedListing" $ \obj ->
311 AST.DetailedListing
312 <$> ((obj .:? "values" .!= Null) >>= parseValues)
313 <*> return mempty
314 <*> (fmap (C ([], []) . C []) <$> (obj .:? "types" .!= mempty))
315 where
316 parseValues = \case
317 Aeson.Array json ->
318 Map.fromList . fmap (, C ([], []) ()) <$> parseJSON (Array json)
319
320 Aeson.Null ->
321 return mempty
322
323 json ->
324 -- TODO: ignore entries where value is False
325 fmap (C ([], []) . (\(b :: Bool) -> ())) <$> parseJSON json
326
327
328 instance ToJSON (AST.Listing (AST.CommentedMap UppercaseIdentifier ())) where
329 toJSON = undefined
330 toEncoding = \case
331 AST.ExplicitListing tags _ ->
332 toEncoding $ Map.fromList $ (\(UppercaseIdentifier k, C _ ()) -> (k, True)) <$> Map.toList tags
333 AST.OpenListing (C _ ()) -> toEncoding ("AllTags" :: Text)
334 AST.ClosedListing -> toEncoding ("NoTags" :: Text)
335
336 instance FromJSON (AST.Listing (AST.CommentedMap UppercaseIdentifier ())) where
337 parseJSON = \case
338 Aeson.String "AllTags" ->
339 return $ AST.OpenListing (C ([], []) ())
340
341 Aeson.Bool True ->
342 return $ AST.OpenListing (C ([], []) ())
343
344 Aeson.String "NoTags" ->
345 return AST.ClosedListing
346
347 Aeson.Bool False ->
348 return AST.ClosedListing
349
350 Aeson.Null ->
351 return AST.ClosedListing
352
353 json ->
354 fail ("unexpected TagListing: " <> show json)
355
356 {-| An Int64 that encodes to a JSON String if necessary to preserve accuracy. -}
357 newtype SafeInt
358 = SafeInt { fromSafeInt :: Int64 }
359
360 instance ToJSON SafeInt where
361 toJSON = undefined
362 toEncoding = \case
363 SafeInt value ->
364 if value <= 9007199254740991 && value >= -9007199254740991
365 then toEncoding value
366 else toEncoding $ show value
367
368 instance FromJSON SafeInt where
369 parseJSON = \case
370 Aeson.Number n -> SafeInt <$> parseJSON (Aeson.Number n)
371 Aeson.String s -> SafeInt . read <$> parseJSON (Aeson.String s)
372 _ -> fail "expected an integer (or a string representing an integer)"
373
374
375 instance ToJSON AST.LiteralValue where
376 toJSON = undefined
377 toEncoding = pairs . toPairs
378
379 instance ToPairs AST.LiteralValue where
380 toPairs = \case
381 IntNum value repr ->
382 mconcat
383 [ type_ "IntLiteral"
384 , "value" .= SafeInt value
385 , pair "display" $ pairs
386 ("representation" .= repr)
387 ]
388
389 FloatNum value repr ->
390 mconcat
391 [ type_ "FloatLiteral"
392 , "value" .= value
393 , pair "display" $ pairs
394 ("representation" .= repr)
395 ]
396
397 Boolean value ->
398 mconcat
399 [ type_ "ExternalReference"
400 , "module" .= UppercaseIdentifier "Basics"
401 , "identifier" .= show value
402 ]
403
404 Chr chr ->
405 mconcat
406 [ type_ "CharLiteral"
407 , "value" .= chr
408 ]
409
410 Str str repr ->
411 mconcat
412 [ type_ "StringLiteral"
413 , "value" .= str
414 , pair "display" $ pairs
415 ("representation" .= repr)
416 ]
417
418 instance FromJSON AST.LiteralValue where
419 parseJSON = withObject "LiteralValue" $ \obj -> do
420 tag <- obj .: "tag"
421 case tag of
422 "IntLiteral" ->
423 AST.IntNum
424 <$> (fromSafeInt <$> obj .: "value")
425 <*> return DecimalInt
426
427 "FloatLiteral" ->
428 AST.FloatNum
429 <$> obj .: "value"
430 <*> return DecimalFloat
431
432 "CharLiteral" ->
433 AST.Chr
434 <$> obj .: "value"
435
436 "StringLiteral" ->
437 AST.Str
438 <$> obj .: "value"
439 <*> return SingleQuotedString
440
441 _ ->
442 fail ("unexpected LiteralValue tag: " <> tag)
443
444
445 instance FromJSON (Ref ()) where
446 parseJSON = withText "Ref" $ \text ->
447 case refFromText text of
448 Nothing ->
449 fail ("invalid Reference name: " <> Text.unpack text)
450
451 Just ref ->
452 return ref
453
454
455 instance ToJSON IntRepresentation where
456 toEncoding = genericToEncoding defaultOptions
457
458
459 instance ToJSON FloatRepresentation where
460 toEncoding = genericToEncoding defaultOptions
461
462
463 instance ToJSON StringRepresentation where
464 toEncoding = genericToEncoding defaultOptions
465
466
467 instance (ToJSON a, ToJSON (f a)) => ToJSON (MaybeF f a) where
468 toJSON = undefined
469 toEncoding = \case
470 JustF fa -> toEncoding fa
471 NothingF a -> toEncoding a
472
473 instance (FromJSON (f a)) => FromJSON (MaybeF f a) where
474 parseJSON json =
475 -- TODO: should this fall back to parsing an `a`?
476 JustF <$> parseJSON json
477
478
479
480 --
481 -- Stuff the should be removed later
482 --
483
484
485 nowhere :: Region.Position
486 nowhere =
487 Region.Position 0 0
488
489
490 noRegion :: a -> Reporting.Annotation.Located a
491 noRegion =
492 Reporting.Annotation.at nowhere nowhere