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