Decode.hs

-- Note: this is an automatically generated file. Do not edit.

-- | JSON decoding for Hydra terms. Converts JSON Values to Terms using Either for error handling.

module Hydra.Json.Decode where

import qualified Hydra.Core as Core
import qualified Hydra.Json.Model as Model
import qualified Hydra.Lib.Eithers as Eithers
import qualified Hydra.Lib.Equality as Equality
import qualified Hydra.Lib.Lists as Lists
import qualified Hydra.Lib.Literals as Literals
import qualified Hydra.Lib.Logic as Logic
import qualified Hydra.Lib.Maps as Maps
import qualified Hydra.Lib.Maybes as Maybes
import qualified Hydra.Lib.Sets as Sets
import qualified Hydra.Lib.Strings as Strings
import qualified Hydra.Rewriting as Rewriting
import qualified Hydra.Show.Core as Core_
import Prelude hiding  (Enum, Ordering, decodeFloat, encodeFloat, fail, map, pure, sum)
import qualified Data.ByteString as B
import qualified Data.Int as I
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S

-- | Decode a JSON value to a float term. Float64/Bigfloat from numbers; Float32 from string.
decodeFloat :: Core.FloatType -> Model.Value -> Either String Core.Term
decodeFloat ft value =
    case ft of
      Core.FloatTypeBigfloat ->
        let numResult = expectNumber value
        in (Eithers.map (\n -> Core.TermLiteral (Core.LiteralFloat (Core.FloatValueBigfloat n))) numResult)
      Core.FloatTypeFloat32 ->
        let strResult = expectString value
        in (Eithers.either (\err -> Left err) (\s ->
          let parsed = Literals.readFloat32 s
          in (Maybes.maybe (Left (Strings.cat [
            "invalid float32: ",
            s])) (\v -> Right (Core.TermLiteral (Core.LiteralFloat (Core.FloatValueFloat32 v)))) parsed)) strResult)
      Core.FloatTypeFloat64 ->
        let numResult = expectNumber value
        in (Eithers.map (\n -> Core.TermLiteral (Core.LiteralFloat (Core.FloatValueFloat64 (Literals.bigfloatToFloat64 n)))) numResult)

-- | Decode a JSON value to an integer term. Small ints from numbers; large ints from strings.
decodeInteger :: Core.IntegerType -> Model.Value -> Either String Core.Term
decodeInteger it value =
    case it of
      Core.IntegerTypeBigint ->
        let strResult = expectString value
        in (Eithers.either (\err -> Left err) (\s ->
          let parsed = Literals.readBigint s
          in (Maybes.maybe (Left (Strings.cat [
            "invalid bigint: ",
            s])) (\v -> Right (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueBigint v)))) parsed)) strResult)
      Core.IntegerTypeInt64 ->
        let strResult = expectString value
        in (Eithers.either (\err -> Left err) (\s ->
          let parsed = Literals.readInt64 s
          in (Maybes.maybe (Left (Strings.cat [
            "invalid int64: ",
            s])) (\v -> Right (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt64 v)))) parsed)) strResult)
      Core.IntegerTypeUint32 ->
        let strResult = expectString value
        in (Eithers.either (\err -> Left err) (\s ->
          let parsed = Literals.readUint32 s
          in (Maybes.maybe (Left (Strings.cat [
            "invalid uint32: ",
            s])) (\v -> Right (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueUint32 v)))) parsed)) strResult)
      Core.IntegerTypeUint64 ->
        let strResult = expectString value
        in (Eithers.either (\err -> Left err) (\s ->
          let parsed = Literals.readUint64 s
          in (Maybes.maybe (Left (Strings.cat [
            "invalid uint64: ",
            s])) (\v -> Right (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueUint64 v)))) parsed)) strResult)
      Core.IntegerTypeInt8 ->
        let numResult = expectNumber value
        in (Eithers.map (\n -> Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt8 (Literals.bigintToInt8 (Literals.bigfloatToBigint n))))) numResult)
      Core.IntegerTypeInt16 ->
        let numResult = expectNumber value
        in (Eithers.map (\n -> Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt16 (Literals.bigintToInt16 (Literals.bigfloatToBigint n))))) numResult)
      Core.IntegerTypeInt32 ->
        let numResult = expectNumber value
        in (Eithers.map (\n -> Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt32 (Literals.bigintToInt32 (Literals.bigfloatToBigint n))))) numResult)
      Core.IntegerTypeUint8 ->
        let numResult = expectNumber value
        in (Eithers.map (\n -> Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueUint8 (Literals.bigintToUint8 (Literals.bigfloatToBigint n))))) numResult)
      Core.IntegerTypeUint16 ->
        let numResult = expectNumber value
        in (Eithers.map (\n -> Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueUint16 (Literals.bigintToUint16 (Literals.bigfloatToBigint n))))) numResult)

-- | Decode a JSON value to a literal term
decodeLiteral :: Core.LiteralType -> Model.Value -> Either String Core.Term
decodeLiteral lt value =
    case lt of
      Core.LiteralTypeBinary ->
        let strResult = expectString value
        in (Eithers.map (\s -> Core.TermLiteral (Core.LiteralBinary (Literals.stringToBinary s))) strResult)
      Core.LiteralTypeBoolean -> case value of
        Model.ValueBoolean v1 -> Right (Core.TermLiteral (Core.LiteralBoolean v1))
        _ -> Left "expected boolean"
      Core.LiteralTypeFloat v0 -> decodeFloat v0 value
      Core.LiteralTypeInteger v0 -> decodeInteger v0 value
      Core.LiteralTypeString ->
        let strResult = expectString value
        in (Eithers.map (\s -> Core.TermLiteral (Core.LiteralString s)) strResult)

-- | Extract an array from a JSON value
expectArray :: Model.Value -> Either String [Model.Value]
expectArray value =
    case value of
      Model.ValueArray v0 -> Right v0
      _ -> Left "expected array"

-- | Extract a number from a JSON value
expectNumber :: Model.Value -> Either String Double
expectNumber value =
    case value of
      Model.ValueNumber v0 -> Right v0
      _ -> Left "expected number"

-- | Extract an object from a JSON value
expectObject :: Model.Value -> Either String (M.Map String Model.Value)
expectObject value =
    case value of
      Model.ValueObject v0 -> Right v0
      _ -> Left "expected object"

-- | Extract a string from a JSON value
expectString :: Model.Value -> Either String String
expectString value =
    case value of
      Model.ValueString v0 -> Right v0
      _ -> Left "expected string"

-- | Decode a JSON value to a Hydra term given a type and type name. Returns Left for type mismatches.
fromJson :: M.Map Core.Name Core.Type -> Core.Name -> Core.Type -> Model.Value -> Either String Core.Term
fromJson types tname typ value =

      let stripped = Rewriting.deannotateType typ
      in case stripped of
        Core.TypeLiteral v0 -> decodeLiteral v0 value
        Core.TypeList v0 ->
          let decodeElem = \v -> fromJson types tname v0 v
              arrResult = expectArray value
          in (Eithers.either (\err -> Left err) (\arr ->
            let decoded = Eithers.mapList decodeElem arr
            in (Eithers.map (\ts -> Core.TermList ts) decoded)) arrResult)
        Core.TypeSet v0 ->
          let decodeElem = \v -> fromJson types tname v0 v
              arrResult = expectArray value
          in (Eithers.either (\err -> Left err) (\arr ->
            let decoded = Eithers.mapList decodeElem arr
            in (Eithers.map (\elems -> Core.TermSet (Sets.fromList elems)) decoded)) arrResult)
        Core.TypeMaybe v0 ->
          let decodeJust = \arr -> Eithers.map (\v -> Core.TermMaybe (Just v)) (fromJson types tname v0 (Lists.head arr))
              decodeMaybeArray =
                      \arr ->
                        let len = Lists.length arr
                        in (Logic.ifElse (Equality.equal len 0) (Right (Core.TermMaybe Nothing)) (Logic.ifElse (Equality.equal len 1) (decodeJust arr) (Left "expected single-element array for Just")))
          in case value of
            Model.ValueNull -> Right (Core.TermMaybe Nothing)
            Model.ValueArray v1 -> decodeMaybeArray v1
            _ -> Left "expected null or single-element array for Maybe"
        Core.TypeRecord v0 ->
          let objResult = expectObject value
          in (Eithers.either (\err -> Left err) (\obj ->
            let decodeField =
                    \ft ->
                      let fname = Core.fieldTypeName ft
                          ftype = Core.fieldTypeType ft
                          mval = Maps.lookup (Core.unName fname) obj
                          defaultVal = Model.ValueNull
                          jsonVal = Maybes.fromMaybe defaultVal mval
                          decoded = fromJson types tname ftype jsonVal
                      in (Eithers.map (\v -> Core.Field {
                        Core.fieldName = fname,
                        Core.fieldTerm = v}) decoded)
                decodedFields = Eithers.mapList decodeField v0
            in (Eithers.map (\fs -> Core.TermRecord (Core.Record {
              Core.recordTypeName = tname,
              Core.recordFields = fs})) decodedFields)) objResult)
        Core.TypeUnion v0 ->
          let decodeVariant =
                  \key -> \val -> \ftype ->
                    let jsonVal = Maybes.fromMaybe Model.ValueNull val
                        decoded = fromJson types tname ftype jsonVal
                    in (Eithers.map (\v -> Core.TermUnion (Core.Injection {
                      Core.injectionTypeName = tname,
                      Core.injectionField = Core.Field {
                        Core.fieldName = (Core.Name key),
                        Core.fieldTerm = v}})) decoded)
              tryField =
                      \key -> \val -> \ft -> Logic.ifElse (Equality.equal (Core.unName (Core.fieldTypeName ft)) key) (Just (decodeVariant key val (Core.fieldTypeType ft))) Nothing
              findAndDecode =
                      \key -> \val -> \fts -> Logic.ifElse (Lists.null fts) (Left (Strings.cat [
                        "unknown variant: ",
                        key])) (Maybes.maybe (findAndDecode key val (Lists.tail fts)) (\r -> r) (tryField key val (Lists.head fts)))
              decodeSingleKey = \obj -> findAndDecode (Lists.head (Maps.keys obj)) (Maps.lookup (Lists.head (Maps.keys obj)) obj) v0
              processUnion =
                      \obj -> Logic.ifElse (Equality.equal (Lists.length (Maps.keys obj)) 1) (decodeSingleKey obj) (Left "expected single-key object for union")
              objResult = expectObject value
          in (Eithers.either (\err -> Left err) (\obj -> processUnion obj) objResult)
        Core.TypeUnit ->
          let objResult = expectObject value
          in (Eithers.map (\_ -> Core.TermUnit) objResult)
        Core.TypeWrap v0 ->
          let decoded = fromJson types tname v0 value
          in (Eithers.map (\v -> Core.TermWrap (Core.WrappedTerm {
            Core.wrappedTermTypeName = tname,
            Core.wrappedTermBody = v})) decoded)
        Core.TypeMap v0 ->
          let keyType = Core.mapTypeKeys v0
              valType = Core.mapTypeValues v0
              arrResult = expectArray value
          in (Eithers.either (\err -> Left err) (\arr ->
            let decodeEntry =
                    \entryJson ->
                      let objResult = expectObject entryJson
                      in (Eithers.either (\err -> Left err) (\entryObj ->
                        let keyJson = Maps.lookup "@key" entryObj
                            valJson = Maps.lookup "@value" entryObj
                        in (Maybes.maybe (Left "missing @key in map entry") (\kj -> Maybes.maybe (Left "missing @value in map entry") (\vj ->
                          let decodedKey = fromJson types tname keyType kj
                              decodedVal = fromJson types tname valType vj
                          in (Eithers.either (\err -> Left err) (\k -> Eithers.map (\v -> (k, v)) decodedVal) decodedKey)) valJson) keyJson)) objResult)
                entries = Eithers.mapList decodeEntry arr
            in (Eithers.map (\es -> Core.TermMap (Maps.fromList es)) entries)) arrResult)
        Core.TypePair v0 ->
          let firstType = Core.pairTypeFirst v0
              secondType = Core.pairTypeSecond v0
              objResult = expectObject value
          in (Eithers.either (\err -> Left err) (\obj ->
            let firstJson = Maps.lookup "@first" obj
                secondJson = Maps.lookup "@second" obj
            in (Maybes.maybe (Left "missing @first in pair") (\fj -> Maybes.maybe (Left "missing @second in pair") (\sj ->
              let decodedFirst = fromJson types tname firstType fj
                  decodedSecond = fromJson types tname secondType sj
              in (Eithers.either (\err -> Left err) (\f -> Eithers.map (\s -> Core.TermPair (f, s)) decodedSecond) decodedFirst)) secondJson) firstJson)) objResult)
        Core.TypeEither v0 ->
          let leftType = Core.eitherTypeLeft v0
              rightType = Core.eitherTypeRight v0
              objResult = expectObject value
          in (Eithers.either (\err -> Left err) (\obj ->
            let leftJson = Maps.lookup "@left" obj
                rightJson = Maps.lookup "@right" obj
            in (Maybes.maybe (Maybes.maybe (Left "expected @left or @right in Either") (\rj ->
              let decoded = fromJson types tname rightType rj
              in (Eithers.map (\v -> Core.TermEither (Right v)) decoded)) rightJson) (\lj ->
              let decoded = fromJson types tname leftType lj
              in (Eithers.map (\v -> Core.TermEither (Left v)) decoded)) leftJson)) objResult)
        Core.TypeVariable v0 ->
          let lookedUp = Maps.lookup v0 types
          in (Maybes.maybe (Left (Strings.cat [
            "unknown type variable: ",
            (Core.unName v0)])) (\resolvedType -> fromJson types v0 resolvedType value) lookedUp)
        _ -> Left (Strings.cat [
          "unsupported type for JSON decoding: ",
          (Core_.type_ typ)])