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