{-# LANGUAGE NoOverloadedStrings #-}
module Language.PureScript.CoreFn.ToJSON
( moduleToJSON
) where
import Prelude.Compat
import Control.Arrow ((***))
import Data.Either (isLeft)
import Data.Maybe (maybe)
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.AST.SourcePos (SourceSpan(SourceSpan))
import Language.PureScript.CoreFn
import Language.PureScript.Names
import Language.PureScript.PSString (PSString)
constructorTypeToJSON :: ConstructorType -> Value
constructorTypeToJSON ProductType = toJSON "ProductType"
constructorTypeToJSON SumType = toJSON "SumType"
metaToJSON :: Meta -> Value
metaToJSON (IsConstructor t is)
= object
[ T.pack "metaType" .= "IsConstructor"
, T.pack "constructorType" .= constructorTypeToJSON t
, T.pack "identifiers" .= identToJSON `map` is
]
metaToJSON IsNewtype = object [ T.pack "metaType" .= "IsNewtype" ]
metaToJSON IsTypeClassConstructor = object [ T.pack "metaType" .= "IsTypeClassConstructor" ]
metaToJSON IsForeign = object [ T.pack "metaType" .= "IsForeign" ]
metaToJSON IsWhere = object [ T.pack "metaType" .= "IsWhere" ]
sourceSpanToJSON :: SourceSpan -> Value
sourceSpanToJSON (SourceSpan _ spanStart spanEnd) =
object [ T.pack "start" .= spanStart
, T.pack "end" .= spanEnd
]
annToJSON :: Ann -> Value
annToJSON (ss, _, _, m) = object [ T.pack "sourceSpan" .= sourceSpanToJSON ss
, T.pack "meta" .= maybe Null metaToJSON m
]
literalToJSON :: (a -> Value) -> Literal a -> Value
literalToJSON _ (NumericLiteral (Left n))
= object
[ T.pack "literalType" .= "IntLiteral"
, T.pack "value" .= n
]
literalToJSON _ (NumericLiteral (Right n))
= object
[ T.pack "literalType" .= "NumberLiteral"
, T.pack "value" .= n
]
literalToJSON _ (StringLiteral s)
= object
[ T.pack "literalType" .= "StringLiteral"
, T.pack "value" .= s
]
literalToJSON _ (CharLiteral c)
= object
[ T.pack "literalType" .= "CharLiteral"
, T.pack "value" .= c
]
literalToJSON _ (BooleanLiteral b)
= object
[ T.pack "literalType" .= "BooleanLiteral"
, T.pack "value" .= b
]
literalToJSON t (ArrayLiteral xs)
= object
[ T.pack "literalType" .= "ArrayLiteral"
, T.pack "value" .= map t xs
]
literalToJSON t (ObjectLiteral xs)
= object
[ T.pack "literalType" .= "ObjectLiteral"
, T.pack "value" .= recordToJSON t xs
]
identToJSON :: Ident -> Value
identToJSON = toJSON . runIdent
properNameToJSON :: ProperName a -> Value
properNameToJSON = toJSON . runProperName
qualifiedToJSON :: (a -> Text) -> Qualified a -> Value
qualifiedToJSON f (Qualified mn a) = object
[ T.pack "moduleName" .= maybe Null moduleNameToJSON mn
, T.pack "identifier" .= toJSON (f a)
]
moduleNameToJSON :: ModuleName -> Value
moduleNameToJSON (ModuleName pns) = toJSON $ properNameToJSON `map` pns
moduleToJSON :: Version -> Module Ann -> Value
moduleToJSON v m = object
[ T.pack "sourceSpan" .= sourceSpanToJSON (moduleSourceSpan m)
, T.pack "moduleName" .= moduleNameToJSON (moduleName m)
, T.pack "modulePath" .= toJSON (modulePath m)
, T.pack "imports" .= map importToJSON (moduleImports m)
, T.pack "exports" .= map identToJSON (moduleExports m)
, T.pack "foreign" .= map identToJSON (moduleForeign m)
, T.pack "decls" .= map bindToJSON (moduleDecls m)
, T.pack "builtWith" .= toJSON (showVersion v)
, T.pack "comments" .= map toJSON (moduleComments m)
]
where
importToJSON (ann,mn) = object
[ T.pack "annotation" .= annToJSON ann
, T.pack "moduleName" .= moduleNameToJSON mn
]
bindToJSON :: Bind Ann -> Value
bindToJSON (NonRec ann n e)
= object
[ T.pack "bindType" .= "NonRec"
, T.pack "annotation" .= annToJSON ann
, T.pack "identifier" .= identToJSON n
, T.pack "expression" .= exprToJSON e
]
bindToJSON (Rec bs)
= object
[ T.pack "bindType" .= "Rec"
, T.pack "binds" .= map (\((ann, n), e)
-> object
[ T.pack "identifier" .= identToJSON n
, T.pack "annotation" .= annToJSON ann
, T.pack "expression" .= exprToJSON e
]) bs
]
recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value
recordToJSON f = toJSON . map (toJSON *** f)
exprToJSON :: Expr Ann -> Value
exprToJSON (Var ann i) = object [ T.pack "type" .= toJSON "Var"
, T.pack "annotation" .= annToJSON ann
, T.pack "value" .= qualifiedToJSON runIdent i
]
exprToJSON (Literal ann l) = object [ T.pack "type" .= "Literal"
, T.pack "annotation" .= annToJSON ann
, T.pack "value" .= literalToJSON exprToJSON l
]
exprToJSON (Constructor ann d c is) = object [ T.pack "type" .= "Constructor"
, T.pack "annotation" .= annToJSON ann
, T.pack "typeName" .= properNameToJSON d
, T.pack "constructorName" .= properNameToJSON c
, T.pack "fieldNames" .= map identToJSON is
]
exprToJSON (Accessor ann f r) = object [ T.pack "type" .= "Accessor"
, T.pack "annotation" .= annToJSON ann
, T.pack "fieldName" .= f
, T.pack "expression" .= exprToJSON r
]
exprToJSON (ObjectUpdate ann r fs) = object [ T.pack "type" .= "ObjectUpdate"
, T.pack "annotation" .= annToJSON ann
, T.pack "expression" .= exprToJSON r
, T.pack "updates" .= recordToJSON exprToJSON fs
]
exprToJSON (Abs ann p b) = object [ T.pack "type" .= "Abs"
, T.pack "annotation" .= annToJSON ann
, T.pack "argument" .= identToJSON p
, T.pack "body" .= exprToJSON b
]
exprToJSON (App ann f x) = object [ T.pack "type" .= "App"
, T.pack "annotation" .= annToJSON ann
, T.pack "abstraction" .= exprToJSON f
, T.pack "argument" .= exprToJSON x
]
exprToJSON (Case ann ss cs) = object [ T.pack "type" .= "Case"
, T.pack "annotation" .= annToJSON ann
, T.pack "caseExpressions"
.= map exprToJSON ss
, T.pack "caseAlternatives"
.= map caseAlternativeToJSON cs
]
exprToJSON (Let ann bs e) = object [ T.pack "type" .= "Let"
, T.pack "annotation" .= annToJSON ann
, T.pack "binds" .= map bindToJSON bs
, T.pack "expression" .= exprToJSON e
]
caseAlternativeToJSON :: CaseAlternative Ann -> Value
caseAlternativeToJSON (CaseAlternative bs r') =
let isGuarded = isLeft r'
in object
[ T.pack "binders" .= toJSON (map binderToJSON bs)
, T.pack "isGuarded" .= toJSON isGuarded
, T.pack (if isGuarded then "expressions" else "expression")
.= case r' of
Left rs -> toJSON $ map (\(g, e) -> object [ T.pack "guard" .= exprToJSON g, T.pack "expression" .= exprToJSON e]) rs
Right r -> exprToJSON r
]
binderToJSON :: Binder Ann -> Value
binderToJSON (VarBinder ann v) = object [ T.pack "binderType" .= "VarBinder"
, T.pack "annotation" .= annToJSON ann
, T.pack "identifier" .= identToJSON v
]
binderToJSON (NullBinder ann) = object [ T.pack "binderType" .= "NullBinder"
, T.pack "annotation" .= annToJSON ann
]
binderToJSON (LiteralBinder ann l) = object [ T.pack "binderType" .= "LiteralBinder"
, T.pack "annotation" .= annToJSON ann
, T.pack "literal" .= literalToJSON binderToJSON l
]
binderToJSON (ConstructorBinder ann d c bs) = object [ T.pack "binderType" .= "ConstructorBinder"
, T.pack "annotation" .= annToJSON ann
, T.pack "typeName" .= qualifiedToJSON runProperName d
, T.pack "constructorName"
.= qualifiedToJSON runProperName c
, T.pack "binders" .= map binderToJSON bs
]
binderToJSON (NamedBinder ann n b) = object [ T.pack "binderType" .= "NamedBinder"
, T.pack "annotation" .= annToJSON ann
, T.pack "identifier" .= identToJSON n
, T.pack "binder" .= binderToJSON b
]