FromJSON.hs

-- |
-- Read the core functional representation from JSON format
--

module Language.PureScript.CoreFn.FromJSON
  ( moduleFromJSON
  , parseVersion'
  ) where

import Prelude

import Control.Applicative ((<|>))

import Data.Aeson (FromJSON(..), Object, Value(..), withObject, withText, (.:))
import Data.Aeson.Types (Parser, listParser)
import Data.Map.Strict qualified as M
import Data.Text (Text)
import Data.Text qualified as T
import Data.Vector qualified as V
import Data.Version (Version, parseVersion)

import Language.PureScript.AST.SourcePos (SourceSpan(..))
import Language.PureScript.AST.Literals (Literal(..))
import Language.PureScript.CoreFn.Ann (Ann)
import Language.PureScript.CoreFn (Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Meta(..), Module(..))
import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), unusedIdent)
import Language.PureScript.PSString (PSString)

import Text.ParserCombinators.ReadP (readP_to_S)

parseVersion' :: String -> Maybe Version
parseVersion' str =
  case filter (null . snd) $ readP_to_S parseVersion str of
    [(vers, "")] -> Just vers
    _            -> Nothing

constructorTypeFromJSON :: Value -> Parser ConstructorType
constructorTypeFromJSON v = do
  t <- parseJSON v
  case t of
    "ProductType" -> return ProductType
    "SumType"     -> return SumType
    _             -> fail ("not recognized ConstructorType: " ++ T.unpack t)

metaFromJSON :: Value -> Parser (Maybe Meta)
metaFromJSON Null = return Nothing
metaFromJSON v = withObject "Meta" metaFromObj v
  where
    metaFromObj o = do
      type_ <- o .: "metaType"
      case type_ of
        "IsConstructor" -> isConstructorFromJSON o
        "IsNewtype"     -> return $ Just IsNewtype
        "IsTypeClassConstructor"
                        -> return $ Just IsTypeClassConstructor
        "IsForeign"     -> return $ Just IsForeign
        "IsWhere"       -> return $ Just IsWhere
        "IsSyntheticApp"
                        -> return $ Just IsSyntheticApp
        _               -> fail ("not recognized Meta: " ++ T.unpack type_)

    isConstructorFromJSON o = do
      ct <- o .: "constructorType" >>= constructorTypeFromJSON
      is <- o .: "identifiers" >>= listParser identFromJSON
      return $ Just (IsConstructor ct is)

annFromJSON :: FilePath -> Value -> Parser Ann
annFromJSON modulePath = withObject "Ann" annFromObj
  where
  annFromObj o = do
    ss <- o .: "sourceSpan" >>= sourceSpanFromJSON modulePath
    mm <- o .: "meta" >>= metaFromJSON
    return (ss, [], mm)

sourceSpanFromJSON :: FilePath -> Value -> Parser SourceSpan
sourceSpanFromJSON modulePath = withObject "SourceSpan" $ \o ->
  SourceSpan modulePath <$>
    o .: "start" <*>
    o .: "end"

literalFromJSON :: (Value -> Parser a) -> Value -> Parser (Literal a)
literalFromJSON t = withObject "Literal" literalFromObj
  where
  literalFromObj o = do
    type_ <- o .: "literalType" :: Parser Text
    case type_ of
      "IntLiteral"      -> NumericLiteral . Left <$> o .: "value"
      "NumberLiteral"   -> NumericLiteral . Right <$> o .: "value"
      "StringLiteral"   -> StringLiteral <$> o .: "value"
      "CharLiteral"     -> CharLiteral <$> o .: "value"
      "BooleanLiteral"  -> BooleanLiteral <$> o .: "value"
      "ArrayLiteral"    -> parseArrayLiteral o
      "ObjectLiteral"   -> parseObjectLiteral o
      _                 -> fail ("error parsing Literal: " ++ show o)

  parseArrayLiteral o = do
    val <- o .: "value"
    as <- mapM t (V.toList val)
    return $ ArrayLiteral as

  parseObjectLiteral o = do
    val <- o .: "value"
    ObjectLiteral <$> recordFromJSON t val

identFromJSON :: Value -> Parser Ident
identFromJSON = withText "Ident" $ \case
  ident | ident == unusedIdent -> pure UnusedIdent 
        | otherwise -> pure $ Ident ident 

properNameFromJSON :: Value -> Parser (ProperName a)
properNameFromJSON = fmap ProperName . parseJSON

qualifiedFromJSON :: (Text -> a) -> Value -> Parser (Qualified a)
qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj
  where
  qualifiedFromObj o =
    qualifiedByModuleFromObj o <|> qualifiedBySourcePosFromObj o
  qualifiedByModuleFromObj o = do
    mn <- o .: "moduleName" >>= moduleNameFromJSON
    i  <- o .: "identifier" >>= withText "Ident" (return . f)
    pure $ Qualified (ByModuleName mn) i
  qualifiedBySourcePosFromObj o = do
    ss <- o .: "sourcePos"
    i  <- o .: "identifier" >>= withText "Ident" (return . f)
    pure $ Qualified (BySourcePos ss) i

moduleNameFromJSON :: Value -> Parser ModuleName
moduleNameFromJSON v = ModuleName . T.intercalate "." <$> listParser parseJSON v

moduleFromJSON :: Value -> Parser (Version, Module Ann)
moduleFromJSON = withObject "Module" moduleFromObj
  where
  moduleFromObj o = do
    version <- o .: "builtWith" >>= versionFromJSON
    moduleName <- o .: "moduleName" >>= moduleNameFromJSON
    modulePath <- o .: "modulePath"
    moduleSourceSpan <- o .: "sourceSpan" >>= sourceSpanFromJSON modulePath
    moduleImports <- o .: "imports" >>= listParser (importFromJSON modulePath)
    moduleExports <- o .: "exports" >>= listParser identFromJSON
    moduleReExports <- o .: "reExports" >>= reExportsFromJSON
    moduleDecls <- o .: "decls" >>= listParser (bindFromJSON modulePath)
    moduleForeign <- o .: "foreign" >>= listParser identFromJSON
    moduleComments <- o .: "comments" >>= listParser parseJSON
    return (version, Module {..})

  versionFromJSON :: String -> Parser Version
  versionFromJSON v =
    case parseVersion' v of
      Just r -> return r
      Nothing -> fail "failed parsing purs version"

  importFromJSON :: FilePath -> Value -> Parser (Ann, ModuleName)
  importFromJSON modulePath = withObject "Import"
    (\o -> do
      ann <- o .: "annotation" >>= annFromJSON modulePath
      mn  <- o .: "moduleName" >>= moduleNameFromJSON
      return (ann, mn))

  reExportsFromJSON :: Value -> Parser (M.Map ModuleName [Ident])
  reExportsFromJSON = fmap (M.map (map Ident)) . parseJSON

bindFromJSON :: FilePath -> Value -> Parser (Bind Ann)
bindFromJSON modulePath = withObject "Bind" bindFromObj
  where
  bindFromObj :: Object -> Parser (Bind Ann)
  bindFromObj o = do
    type_ <- o .: "bindType" :: Parser Text
    case type_ of
      "NonRec"  -> (uncurry . uncurry) NonRec <$> bindFromObj' o
      "Rec"     -> Rec <$> (o .: "binds" >>= listParser (withObject "Bind" bindFromObj'))
      _         -> fail ("not recognized bind type \"" ++ T.unpack type_ ++ "\"")
        
  bindFromObj' :: Object -> Parser ((Ann, Ident), Expr Ann)
  bindFromObj' o = do
    a <- o .: "annotation" >>= annFromJSON modulePath
    i <- o .: "identifier" >>= identFromJSON
    e <- o .: "expression" >>= exprFromJSON modulePath
    return ((a, i), e)

recordFromJSON :: (Value -> Parser a) -> Value -> Parser [(PSString, a)]
recordFromJSON p = listParser parsePair
  where
  parsePair v = do
    (l, v') <- parseJSON v :: Parser (PSString, Value)
    a <- p v'
    return (l, a)

exprFromJSON :: FilePath -> Value -> Parser (Expr Ann)
exprFromJSON modulePath = withObject "Expr" exprFromObj
  where
  exprFromObj o = do
    type_ <- o .: "type"
    case type_ of
      "Var"           -> varFromObj o
      "Literal"       -> literalExprFromObj o
      "Constructor"   -> constructorFromObj o
      "Accessor"      -> accessorFromObj o
      "ObjectUpdate"  -> objectUpdateFromObj o
      "Abs"           -> absFromObj o
      "App"           -> appFromObj o
      "Case"          -> caseFromObj o
      "Let"           -> letFromObj o
      _               -> fail ("not recognized expression type: \"" ++ T.unpack type_ ++ "\"")

  varFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    qi <- o .: "value" >>= qualifiedFromJSON Ident
    return $ Var ann qi

  literalExprFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    lit <- o .: "value" >>= literalFromJSON (exprFromJSON modulePath)
    return $ Literal ann lit

  constructorFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    tyn <- o .: "typeName" >>= properNameFromJSON
    con <- o .: "constructorName" >>= properNameFromJSON
    is  <- o .: "fieldNames" >>= listParser identFromJSON
    return $ Constructor ann tyn con is

  accessorFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    f   <- o .: "fieldName"
    e <- o .: "expression" >>= exprFromJSON modulePath
    return $ Accessor ann f e

  objectUpdateFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    e   <- o .: "expression" >>= exprFromJSON modulePath
    copy <- o .: "copy" >>= parseJSON
    us  <- o .: "updates" >>= recordFromJSON (exprFromJSON modulePath)
    return $ ObjectUpdate ann e copy us

  absFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    idn <- o .: "argument" >>= identFromJSON
    e   <- o .: "body" >>= exprFromJSON modulePath
    return $ Abs ann idn e

  appFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    e   <- o .: "abstraction" >>= exprFromJSON modulePath
    e'  <- o .: "argument" >>= exprFromJSON modulePath
    return $ App ann e e'

  caseFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    cs  <- o .: "caseExpressions" >>= listParser (exprFromJSON modulePath)
    cas <- o .: "caseAlternatives" >>= listParser (caseAlternativeFromJSON modulePath)
    return $ Case ann cs cas

  letFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    bs  <- o .: "binds" >>= listParser (bindFromJSON modulePath)
    e   <- o .: "expression" >>= exprFromJSON modulePath
    return $ Let ann bs e

caseAlternativeFromJSON :: FilePath -> Value -> Parser (CaseAlternative Ann)
caseAlternativeFromJSON modulePath = withObject "CaseAlternative" caseAlternativeFromObj
  where
    caseAlternativeFromObj o = do
      bs <- o .: "binders" >>= listParser (binderFromJSON modulePath)
      isGuarded <- o .: "isGuarded"
      if isGuarded
        then do
          es <- o .: "expressions" >>= listParser parseResultWithGuard
          return $ CaseAlternative bs (Left es)
        else do
          e <- o .: "expression" >>= exprFromJSON modulePath
          return $ CaseAlternative bs (Right e)

    parseResultWithGuard :: Value -> Parser (Guard Ann, Expr Ann)
    parseResultWithGuard = withObject "parseCaseWithGuards" $
      \o -> do
        g <- o .: "guard" >>= exprFromJSON modulePath
        e <- o .: "expression" >>= exprFromJSON modulePath
        return (g, e)

binderFromJSON :: FilePath -> Value -> Parser (Binder Ann)
binderFromJSON modulePath = withObject "Binder" binderFromObj
  where
  binderFromObj o = do
    type_ <- o .: "binderType"
    case type_ of
      "NullBinder"        -> nullBinderFromObj o
      "VarBinder"         -> varBinderFromObj o
      "LiteralBinder"     -> literalBinderFromObj o
      "ConstructorBinder" -> constructorBinderFromObj o
      "NamedBinder"       -> namedBinderFromObj o
      _                   -> fail ("not recognized binder: \"" ++ T.unpack type_ ++ "\"")


  nullBinderFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    return $ NullBinder ann

  varBinderFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    idn <- o .: "identifier" >>= identFromJSON
    return $ VarBinder ann idn

  literalBinderFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    lit <- o .: "literal" >>= literalFromJSON (binderFromJSON modulePath)
    return $ LiteralBinder ann lit

  constructorBinderFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    tyn <- o .: "typeName" >>= qualifiedFromJSON ProperName
    con <- o .: "constructorName" >>= qualifiedFromJSON ProperName
    bs  <- o .: "binders" >>= listParser (binderFromJSON modulePath)
    return $ ConstructorBinder ann tyn con bs

  namedBinderFromObj o = do
    ann <- o .: "annotation" >>= annFromJSON modulePath
    n   <- o .: "identifier" >>= identFromJSON
    b   <- o .: "binder" >>= binderFromJSON modulePath
    return $ NamedBinder ann n b