{-# 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 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 ]