@@ -0,0 +1,116 @@
1+-- |
2+-- Dump the core functional representation in JSON format for consumption
3+-- by third-party code generators
4+--
5+module Language.PureScript.CoreFn.ToJSON
6+ ( moduleToJSON
7+ ) where
8+
9+import Prelude.Compat
10+
11+import Data.Aeson
12+import Data.Version (Version, showVersion)
13+import Data.Text (pack)
14+
15+import Language.PureScript.AST.Literals
16+import Language.PureScript.CoreFn
17+import Language.PureScript.Names
18+
19+literalToJSON :: (a -> Value) -> Literal a -> Value
20+literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)
21+literalToJSON _ (NumericLiteral (Right n)) = toJSON ("NumberLiteral", n)
22+literalToJSON _ (StringLiteral s) = toJSON ("StringLiteral", s)
23+literalToJSON _ (CharLiteral c) = toJSON ("CharLiteral", c)
24+literalToJSON _ (BooleanLiteral b) = toJSON ("BooleanLiteral", b)
25+literalToJSON t (ArrayLiteral xs) = toJSON ("ArrayLiteral", map t xs)
26+literalToJSON t (ObjectLiteral xs) = toJSON ("ObjectLiteral", recordToJSON t xs)
27+
28+identToJSON :: Ident -> Value
29+identToJSON = toJSON . runIdent
30+
31+properNameToJSON :: ProperName a -> Value
32+properNameToJSON = toJSON . runProperName
33+
34+qualifiedToJSON :: (a -> String) -> Qualified a -> Value
35+qualifiedToJSON f = toJSON . showQualified f
36+
37+moduleNameToJSON :: ModuleName -> Value
38+moduleNameToJSON = toJSON . runModuleName
39+
40+moduleToJSON :: Version -> Module a -> Value
41+moduleToJSON v m = object [ pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m)
42+ , pack "exports" .= map identToJSON (moduleExports m)
43+ , pack "foreign" .= map (identToJSON . fst) (moduleForeign m)
44+ , pack "decls" .= map bindToJSON (moduleDecls m)
45+ , pack "builtWith" .= toJSON (showVersion v)
46+ ]
47+
48+bindToJSON :: Bind a -> Value
49+bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ]
50+bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs
51+
52+recordToJSON :: (a -> Value) -> [(String, a)] -> Value
53+recordToJSON f = object . map (\(label, a) -> pack label .= f a)
54+
55+exprToJSON :: Expr a -> Value
56+exprToJSON (Var _ i) = toJSON ( "Var"
57+ , qualifiedToJSON runIdent i
58+ )
59+exprToJSON (Literal _ l) = toJSON ( "Literal"
60+ , literalToJSON (exprToJSON) l
61+ )
62+exprToJSON (Constructor _ d c is) = toJSON ( "Constructor"
63+ , properNameToJSON d
64+ , properNameToJSON c
65+ , map identToJSON is
66+ )
67+exprToJSON (Accessor _ f r) = toJSON ( "Accessor"
68+ , f
69+ , exprToJSON r
70+ )
71+exprToJSON (ObjectUpdate _ r fs) = toJSON ( "ObjectUpdate"
72+ , exprToJSON r
73+ , recordToJSON exprToJSON fs
74+ )
75+exprToJSON (Abs _ p b) = toJSON ( "Abs"
76+ , identToJSON p
77+ , exprToJSON b
78+ )
79+exprToJSON (App _ f x) = toJSON ( "App"
80+ , exprToJSON f
81+ , exprToJSON x
82+ )
83+exprToJSON (Case _ ss cs) = toJSON ( "Case"
84+ , map exprToJSON ss
85+ , map caseAlternativeToJSON cs
86+ )
87+exprToJSON (Let _ bs e) = toJSON ( "Let"
88+ , map bindToJSON bs
89+ , exprToJSON e
90+ )
91+
92+caseAlternativeToJSON :: CaseAlternative a -> Value
93+caseAlternativeToJSON (CaseAlternative bs r') =
94+ toJSON [ toJSON (map binderToJSON bs)
95+ , case r' of
96+ Left rs -> toJSON $ map (\(g, e) -> (exprToJSON g, exprToJSON e)) rs
97+ Right r -> exprToJSON r
98+ ]
99+
100+binderToJSON :: Binder a -> Value
101+binderToJSON (VarBinder _ v) = toJSON ( "VarBinder"
102+ , identToJSON v
103+ )
104+binderToJSON (NullBinder _) = toJSON "NullBinder"
105+binderToJSON (LiteralBinder _ l) = toJSON ( "LiteralBinder"
106+ , literalToJSON binderToJSON l
107+ )
108+binderToJSON (ConstructorBinder _ d c bs) = toJSON ( "ConstructorBinder"
109+ , qualifiedToJSON runProperName d
110+ , qualifiedToJSON runProperName c
111+ , map binderToJSON bs
112+ )
113+binderToJSON (NamedBinder _ n b) = toJSON ( "NamedBinder"
114+ , identToJSON n
115+ , binderToJSON b
116+ )