forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathToJSON.hs
More file actions
129 lines (114 loc) · 5.94 KB
/
ToJSON.hs
File metadata and controls
129 lines (114 loc) · 5.94 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
{-# LANGUAGE NoOverloadedStrings #-}
-- |
-- Dump the core functional representation in JSON format for consumption
-- by third-party code generators
--
module Language.PureScript.CoreFn.ToJSON
( moduleToJSON
) where
import Prelude.Compat
import Data.Maybe (fromMaybe)
import Data.Aeson
import Data.Version (Version, showVersion)
import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST.Literals
import Language.PureScript.CoreFn
import Language.PureScript.Names
import Language.PureScript.PSString (PSString, decodeString)
literalToJSON :: (a -> Value) -> Literal a -> Value
literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)
literalToJSON _ (NumericLiteral (Right n)) = toJSON ("NumberLiteral", n)
literalToJSON _ (StringLiteral s) = toJSON ("StringLiteral", s)
literalToJSON _ (CharLiteral c) = toJSON ("CharLiteral", c)
literalToJSON _ (BooleanLiteral b) = toJSON ("BooleanLiteral", b)
literalToJSON t (ArrayLiteral xs) = toJSON ("ArrayLiteral", map t xs)
literalToJSON t (ObjectLiteral xs) = toJSON ("ObjectLiteral", recordToJSON t xs)
identToJSON :: Ident -> Value
identToJSON = toJSON . runIdent
properNameToJSON :: ProperName a -> Value
properNameToJSON = toJSON . runProperName
qualifiedToJSON :: (a -> Text) -> Qualified a -> Value
qualifiedToJSON f = toJSON . showQualified f
moduleNameToJSON :: ModuleName -> Value
moduleNameToJSON = toJSON . runModuleName
moduleToJSON :: Version -> Module a -> Value
moduleToJSON v m = object [ T.pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m)
, T.pack "exports" .= map identToJSON (moduleExports m)
, T.pack "foreign" .= map (identToJSON . fst) (moduleForeign m)
, T.pack "decls" .= map bindToJSON (moduleDecls m)
, T.pack "builtWith" .= toJSON (showVersion v)
]
bindToJSON :: Bind a -> Value
bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ]
bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs
-- If all of the labels in the record can safely be converted to JSON strings,
-- we generate a JSON object. Otherwise the labels must be represented as
-- arrays of integers in the JSON, and in this case we generate the record as
-- an array of pairs.
recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value
recordToJSON f rec = fromMaybe (asArrayOfPairs rec) (asObject rec)
where
asObject = fmap object . traverse (uncurry maybePair)
maybePair label a = fmap (\l -> l .= f a) (decodeString label)
asArrayOfPairs = toJSON . map (\(label, a) -> (toJSON label, f a))
exprToJSON :: Expr a -> Value
exprToJSON (Var _ i) = toJSON ( "Var"
, qualifiedToJSON runIdent i
)
exprToJSON (Literal _ l) = toJSON ( "Literal"
, literalToJSON (exprToJSON) l
)
exprToJSON (Constructor _ d c is) = toJSON ( "Constructor"
, properNameToJSON d
, properNameToJSON c
, map identToJSON is
)
exprToJSON (Accessor _ f r) = toJSON ( "Accessor"
, f
, exprToJSON r
)
exprToJSON (ObjectUpdate _ r fs) = toJSON ( "ObjectUpdate"
, exprToJSON r
, recordToJSON exprToJSON fs
)
exprToJSON (Abs _ p b) = toJSON ( "Abs"
, identToJSON p
, exprToJSON b
)
exprToJSON (App _ f x) = toJSON ( "App"
, exprToJSON f
, exprToJSON x
)
exprToJSON (Case _ ss cs) = toJSON ( "Case"
, map exprToJSON ss
, map caseAlternativeToJSON cs
)
exprToJSON (Let _ bs e) = toJSON ( "Let"
, map bindToJSON bs
, exprToJSON e
)
caseAlternativeToJSON :: CaseAlternative a -> Value
caseAlternativeToJSON (CaseAlternative bs r') =
toJSON [ toJSON (map binderToJSON bs)
, case r' of
Left rs -> toJSON $ map (\(g, e) -> (exprToJSON g, exprToJSON e)) rs
Right r -> exprToJSON r
]
binderToJSON :: Binder a -> Value
binderToJSON (VarBinder _ v) = toJSON ( "VarBinder"
, identToJSON v
)
binderToJSON (NullBinder _) = toJSON "NullBinder"
binderToJSON (LiteralBinder _ l) = toJSON ( "LiteralBinder"
, literalToJSON binderToJSON l
)
binderToJSON (ConstructorBinder _ d c bs) = toJSON ( "ConstructorBinder"
, qualifiedToJSON runProperName d
, qualifiedToJSON runProperName c
, map binderToJSON bs
)
binderToJSON (NamedBinder _ n b) = toJSON ( "NamedBinder"
, identToJSON n
, binderToJSON b
)