-- Copyright (c) Microsoft. All rights reserved.

-- Licensed under the MIT license. See LICENSE file in the project root for full license information.



{-# LANGUAGE OverloadedStrings, QuasiQuotes, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}



{-|
Copyright   : (c) Microsoft
License     : MIT
Maintainer  : adamsap@microsoft.com
Stability   : provisional
Portability : portable
-}



module Language.Bond.Syntax.JSON

    ( -- * FromJSON and ToJSON instances

      -- $aeson

    )

    where



import Control.Applicative

import Data.Aeson

import Data.Aeson.TH

import Data.Aeson.Types

import Data.HashMap.Strict (member)

import Data.Text.Lazy (unpack)

import Language.Bond.Syntax.Types hiding (MethodType(..))

import qualified Language.Bond.Syntax.Types as BST (MethodType(..))

import Prelude

import Text.Shakespeare.Text (lt)



-- $aeson

--

-- This module defines 'FromJSON' and 'ToJSON' instances for Bond abstract

-- syntax tree.  They allow using the <http://hackage.haskell.org/package/aeson aeson>

-- library to encode Bond AST types to <https://microsoft.github.io/bond/manual/compiler.html#schema-ast JSON format>:

--

-- > > encode (Bond [] [Namespace Nothing ["example"]] [])

-- > "{\"namespaces\":[{\"name\":[\"example\"]}],\"imports\":[],\"declarations\":[]}"

--

-- and decode Bond data types from JSON:

--

-- > > decode "{\"namespaces\":[{\"name\":[\"example\"]}],\"imports\":[],\"declarations\":[]}" :: Maybe Bond

-- > Just (Bond {bondImports = [], bondNamespaces = [Namespace {nsLanguage = Nothing, nsName = ["example"]}], bondDeclarations = []})



instance FromJSON Type where

    parseJSON (String "int8") = pure BT_Int8

    parseJSON (String "int16") = pure BT_Int16

    parseJSON (String "int32") = pure BT_Int32

    parseJSON (String "int64") = pure BT_Int64

    parseJSON (String "uint8") = pure BT_UInt8

    parseJSON (String "uint16") = pure BT_UInt16

    parseJSON (String "uint32") = pure BT_UInt32

    parseJSON (String "uint64") = pure BT_UInt64

    parseJSON (String "float") = pure BT_Float

    parseJSON (String "double") = pure BT_Double

    parseJSON (String "bool") = pure BT_Bool

    parseJSON (String "string") = pure BT_String

    parseJSON (String "wstring") = pure BT_WString

    parseJSON (String "bond_meta::name") = pure BT_MetaName

    parseJSON (String "bond_meta::full_name") = pure BT_MetaFullName

    parseJSON (String "blob") = pure BT_Blob

    parseJSON (Object o) = do

        type_ <- o .: "type"

        case type_ of

            String "maybe" -> BT_Maybe <$>

                o .: "element"

            String "list" -> BT_List <$>

                o .: "element"

            String "vector" -> BT_Vector <$>

                o .: "element"

            String "nullable" -> BT_Nullable <$>

                o .: "element"

            String "set" -> BT_Set <$>

                o .: "element"

            String "map" -> BT_Map <$>

                o .: "key" <*>

                o .: "element"

            String "bonded" -> BT_Bonded <$>

                o .: "element"

            String "constant" -> BT_IntTypeArg <$>

                o .: "value"

            String "parameter" -> BT_TypeParam <$>

                o .: "value"

            String "user" -> BT_UserDefined <$>

                o .: "declaration" <*>

                o .:? "arguments" .!= []

            _ -> modifyFailure

                    (const $ "Invalid value `" ++ show type_ ++ "` for the `type` key.")

                    empty

    parseJSON x = modifyFailure

                    (const $ "Expected a representation of Type but found: " ++ show x)

                    empty



instance ToJSON Type where

    toJSON BT_Int8 = "int8"

    toJSON BT_Int16 = "int16"

    toJSON BT_Int32 = "int32"

    toJSON BT_Int64 = "int64"

    toJSON BT_UInt8 = "uint8"

    toJSON BT_UInt16 = "uint16"

    toJSON BT_UInt32 = "uint32"

    toJSON BT_UInt64 = "uint64"

    toJSON BT_Float = "float"

    toJSON BT_Double = "double"

    toJSON BT_Bool = "bool"

    toJSON BT_String = "string"

    toJSON BT_WString = "wstring"

    toJSON BT_MetaName = "bond_meta::name"

    toJSON BT_MetaFullName = "bond_meta::full_name"

    toJSON BT_Blob = "blob"

    toJSON (BT_Maybe t) = object

        [ "type" .= String "maybe"

        , "element" .= t

        ]

    toJSON (BT_List t) = object

        [ "type" .= String "list"

        , "element" .= t

        ]

    toJSON (BT_Vector t) = object

        [ "type" .= String "vector"

        , "element" .= t

        ]

    toJSON (BT_Nullable t) = object

        [ "type" .= String "nullable"

        , "element" .= t

        ]

    toJSON (BT_Set t) = object

        [ "type" .= String "set"

        , "element" .= t

        ]

    toJSON (BT_Map k t) = object

        [ "type" .= String "map"

        , "key" .= k

        , "element" .= t

        ]

    toJSON (BT_Bonded t) = object

        [ "type" .= String "bonded"

        , "element" .= t

        ]

    toJSON (BT_IntTypeArg n) = object

        [ "type" .= String "constant"

        , "value" .= n

       ]

    toJSON (BT_TypeParam p) = object

        [ "type" .= String "parameter"

        , "value" .= p

        ]

    toJSON (BT_UserDefined decl []) = object

        [ "type" .= String "user"

        , "declaration" .= decl

        ]

    toJSON (BT_UserDefined decl args) = object

        [ "type" .= String "user"

        , "declaration" .= decl

        , "arguments" .= args

        ]



instance FromJSON Default where

    parseJSON (Object o) = do

        type_ <- o .: "type"

        case type_ of

            String "bool" -> DefaultBool <$> o .: "value"

            String "integer" -> DefaultInteger <$> o .: "value"

            String "float" -> DefaultFloat <$> o .: "value"

            String "string" -> DefaultString <$> o .: "value"

            String "enum" -> DefaultEnum <$> o .: "value"

            String "nothing" -> pure DefaultNothing

            _ -> modifyFailure

                    (const $ "Invalid value `" ++ show type_ ++ "` for the `type` key.")

                    empty

    parseJSON x = modifyFailure

                    (const $ "Expected a representation of Default but found: " ++ show x)

                    empty



instance ToJSON Default where

    toJSON (DefaultBool x) = object

        [ "type" .= String "bool"

        , "value" .= x

        ]

    toJSON (DefaultInteger x) = object

        [ "type" .= String "integer"

        , "value" .= x

        ]

    toJSON (DefaultFloat x) = object

        [ "type" .= String "float"

        , "value" .= x

        ]

    toJSON (DefaultString x) = object

        [ "type" .= String "string"

        , "value" .= x

        ]

    toJSON (DefaultEnum x) = object

        [ "type" .= String "enum"

        , "value" .= x

        ]

    toJSON DefaultNothing = object

        [ "type" .= String "nothing"

        ]



instance FromJSON Field where

    parseJSON (Object o) = Field <$>

        o .:? "fieldAttributes" .!= [] <*>

        o .:  "fieldOrdinal" <*>

        o .:? "fieldModifier" .!= Optional <*>

        o .:  "fieldType" <*>

        o .:  "fieldName" <*>

        o .:? "fieldDefault" .!= Nothing

    parseJSON x = modifyFailure

                    (const $ "Expected a representation of Field but found: " ++ show x)

                    empty



instance ToJSON Field where

    toJSON f = object

        [ "fieldAttributes" .= fieldAttributes f

        , "fieldOrdinal" .= fieldOrdinal f

        , "fieldModifier" .= fieldModifier f

        , "fieldType" .= fieldType f

        , "fieldName" .= fieldName f

        , "fieldDefault" .= fieldDefault f

        ]



instance FromJSON Constraint where

    parseJSON (String "value") = pure Value

    parseJSON x = modifyFailure

                    (const $ "Expected a representation of Constraint but found: " ++ show x)

                    empty



instance ToJSON Constraint where

    toJSON Value = "value"



instance FromJSON Namespace where

    parseJSON (Object v) =

        Namespace <$>

            v .:? "language" <*>

            v .: "name"

    parseJSON x = modifyFailure

                    (const $ "Expected an object but found: " ++ show x)

                    empty



instance ToJSON Namespace where

    toJSON (Namespace Nothing name) = object

        [ "name" .= name

        ]

    toJSON Namespace {..} = object

        [ "language" .= nsLanguage

        , "name" .= nsName

        ]



instance FromJSON Bond where

    parseJSON (Object v) =

        Bond <$>

            v .: "imports" <*>

            v .: "namespaces" <*>

            v .: "declarations"

    parseJSON x = modifyFailure

                    (const $ "Expected an object but found: " ++ show x)

                    empty



instance ToJSON Bond where

    toJSON Bond {..} = object

        [ "imports" .= bondImports

        , "namespaces" .= bondNamespaces

        , "declarations" .= bondDeclarations

        ]



instance ToJSON BST.MethodType where

    toJSON BST.Void = Null

    toJSON (BST.Unary t) = toJSON t

    toJSON (BST.Streaming t) = toJSON t



data MethodStreamingTag = Unary | Client | Server | Duplex deriving Show

$(deriveJSON defaultOptions ''MethodStreamingTag)



methodStreamingTag :: BST.MethodType -> BST.MethodType -> MethodStreamingTag

methodStreamingTag input result = case (input, result) of

  (BST.Streaming _, BST.Streaming _) -> Duplex

  (BST.Streaming _, _) -> Client

  (_, BST.Streaming _) -> Server

  _ -> Unary



instance ToJSON Method where

    toJSON Event {..} = object

        [ "tag" .= String "Event"

        , "methodName" .= methodName

        , "methodAttributes" .= methodAttributes

        , "methodInput" .= methodInput

        ]

    toJSON Function {..} = object

        [ "tag" .= String "Function"

        , "methodName" .= methodName

        , "methodAttributes" .= methodAttributes

        , "methodResult" .= methodResult

        , "methodInput" .= methodInput

        , "methodStreaming" .= (methodStreamingTag methodInput methodResult)

        ]



instance FromJSON Method where

  parseJSON = withObject "Method" (\o -> do

    tag <- o .: "tag"

    methodName :: String <- o .:? "methodName" .!= "<unknown>"

    case tag of

      (String "Event") -> modifyFailure ((unpack [lt|Parsing event '#{show methodName}' failed: |]) ++) (parseEvent o)

      (String "Function") -> modifyFailure ((unpack [lt|Parsing function '#{show methodName}' failed: |]) ++) (parseFunction o)

      _ -> modifyFailure (const $ unpack [lt|Unexpected tag '#{show tag}' when parsing method '#{show methodName}'. Expecting "Event" or "Function".|]) empty)

    where

      parseEvent :: Object -> Parser Method

      parseEvent o =

        Event <$>

          o .:? "methodAttributes" .!= [] <*>

          o .: "methodName" <*>

          methodInput

        <* ensureNoMethodStreaming

        where ensureNoMethodStreaming = if member "methodStreaming" o

                                          then fail "Encountered Event with \"methodStreaming\" member. Events cannot have this member."

                                          else pure ()

              methodInput = maybe BST.Void BST.Unary <$> (o .:? "methodInput")



      parseFunction :: Object -> Parser Method

      parseFunction o =

          Function <$>

            o .:? "methodAttributes" .!= [] <*>

            methodResult <*>

            o .: "methodName" <*>

            methodInput

        where

          streamingTag :: Parser MethodStreamingTag

          streamingTag = o .:? "methodStreaming"  .!= Unary



          methodInput :: Parser BST.MethodType

          methodInput = do

            i <- o .:? "methodInput"

            st <- streamingTag

            case (i, st) of

              (Nothing, Unary) -> pure $ BST.Void

              (Nothing, Client) -> fail $ invalidNothingComboMsg "input" Client

              (Nothing, Server) -> pure $ BST.Void

              (Nothing, Duplex) -> fail $ invalidNothingComboMsg "input" Duplex

              (Just t, Unary) -> pure $ BST.Unary t

              (Just t, Client) -> pure $ BST.Streaming t

              (Just t, Server) -> pure $ BST.Unary t

              (Just t, Duplex) -> pure $ BST.Streaming t



          methodResult :: Parser BST.MethodType

          methodResult = do

            r <- o .:? "methodResult"

            st <- streamingTag

            case (r, st) of

              (Nothing, Unary) -> pure $ BST.Void

              (Nothing, Client) -> pure $ BST.Void

              (Nothing, Server) -> fail $ invalidNothingComboMsg "result" Server

              (Nothing, Duplex) -> fail $ invalidNothingComboMsg "result" Duplex

              (Just t, Unary) -> pure $ BST.Unary t

              (Just t, Client) -> pure $ BST.Unary t

              (Just t, Server) -> pure $ BST.Streaming t

              (Just t, Duplex) -> pure $ BST.Streaming t



          invalidNothingComboMsg :: String -> MethodStreamingTag -> String

          invalidNothingComboMsg dir streaming = unpack [lt|Method marked as #{show streaming}, but has void #{dir}|]



$(deriveJSON defaultOptions ''Modifier)

$(deriveJSON defaultOptions ''Attribute)

$(deriveJSON defaultOptions ''Constant)

$(deriveJSON defaultOptions ''TypeParam)

$(deriveJSON defaultOptions ''Declaration)

$(deriveJSON defaultOptions ''Import)

$(deriveJSON defaultOptions ''Language)