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

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



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



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

{-# OPTIONS_GHC -fno-warn-unused-binds #-}



module Language.Bond.Syntax.SchemaDef

    ( -- * Runtime schema (aka SchemaDef) support

       encodeSchemaDef,

       makeSchemaDef

    ) where



import Data.Word

import Data.List

import Data.Maybe

import Data.Function

import Data.Text.Lazy.Builder

import qualified Data.Foldable as F

import qualified Data.ByteString.Lazy as BL

import qualified Data.Text.Lazy as L

import Data.Monoid

import Control.Applicative hiding (optional)

import Prelude

import Data.Aeson

import Data.Aeson.TH

import Language.Bond.Util

import Language.Bond.Syntax.Types

import Language.Bond.Syntax.Util

import Language.Bond.Codegen.TypeMapping



-- | Returns an instance of <https://microsoft.github.io/bond/manual/compiler.html#runtime-schema SchemaDef>

-- for the specified type. The SchemaDef is encoded using the Bond Simple JSON

-- protocol and returned as a lazy 'BL.ByteString'.

encodeSchemaDef :: Type -> BL.ByteString

encodeSchemaDef = encode . makeSchemaDef



data SchemaDef =

    SchemaDef

        { structs :: [StructDef]

        }



data StructDef =

    StructDef

        { metadata :: Metadata

        , base_def :: Maybe [TypeDef]

        , fields :: [FieldDef]

        }



data FieldDef =

    FieldDef

        { _metadata :: Metadata

        , _id :: Word16

        , _type :: TypeDef

        }



data TypeDef =

    TypeDef

          -- Domain of Int is BondDataType

        { id :: Maybe Int

          -- Index of struct definition in SchemaDef.structs when id == BT_STRUCT

        , struct_def :: Maybe Int

        , element :: Maybe [TypeDef]

        , key :: Maybe [TypeDef]

        , bonded_type :: Maybe Bool

          -- Domain of Int is ListSubType.

          -- Currently not present in TypeDef, as its addition is breaking

          -- some users that have already serialized SchemaDef structs.

          --, list_sub_type :: Maybe Int

        }



data Metadata =

    Metadata

        { name :: String

        , qualified_name :: Maybe String

        , attributes :: Maybe [String]

        , modifier :: Maybe Int

        , default_value :: Maybe Variant

        }



data Variant =

    Variant

        { uint_value :: Maybe Integer

        , int_value :: Maybe Integer

        , double_value :: Maybe Double

        , string_value :: Maybe String

        , wstring_value :: Maybe String

        , nothing :: Maybe Bool

        }



-- Returns BondDataType enum value for a 'Type'. Applies only to scalars/strings

typeId :: Type -> Int

typeId t = case t of

    BT_Bool       -> 2

    BT_UInt8      -> 3

    BT_UInt16     -> 4

    BT_UInt32     -> 5

    BT_UInt64     -> 6

    BT_Float      -> 7

    BT_Double     -> 8

    BT_String     -> 9

    BT_Int8       -> 14

    BT_Int16      -> 15

    BT_Int32      -> 16

    BT_Int64      -> 17

    BT_WString    -> 18

    BT_MetaName   -> typeId BT_String

    BT_MetaFullName -> typeId BT_String

    (BT_UserDefined Enum {} _) -> typeId BT_Int32

    _ -> error "typeId: unexpected type"





makeSchemaDef :: Type -> SchemaDef

makeSchemaDef root = SchemaDef $ map structDef structs

  where

    ctx = MappingContext idlTypeMapping [] [] []

    -- list of structs in the schema

    structs = nub $ f root

      where

        f t@(BT_UserDefined Struct{..} declArgs) = [t]

            <|> optional ((foldMapType f) . resolve) structBase

            <|> F.foldMap ((foldMapType f) . resolve . fieldType) structFields

          where

            resolve = resolveType declParams declArgs

        f _ = mempty

    -- index of a struct in the schema

    structIdx typ@(BT_UserDefined f fArgs) = case findIndex matchingStruct structs of

        Nothing -> error $ "makeSchemaDef.structIdx: struct not found " ++ show typ

        Just n -> n

      where

        matchingStruct (BT_UserDefined s@Struct{} sArgs) =

               declName s == declName f

            && not (null $ intersect (declNamespaces s) (declNamespaces f))

            && sArgs == fArgs

        matchingStruct t = typ == t

    structIdx typ = error $ "makeSchemaDef.structIdx: undefined struct: " ++ show typ

    -- StructDef for the specified struct type

    structDef typ@(BT_UserDefined s@Struct{..} declArgs) = StructDef metadata base fields

      where

        resolve = resolveType declParams declArgs

        structQualifiedName = L.unpack $ toLazyText $ getTypeName ctx typ

        structName = drop (1 + (length $ qualifiedName $ getDeclNamespace ctx s)) structQualifiedName

        metadata = Metadata structName (Just structQualifiedName) (attr declAttributes) Nothing Nothing

        base = pure . typeDef . resolve <$> structBase

        fields = map fieldDef structFields

        fieldDef Field {..} = FieldDef fieldMetadata fieldOrdinal (typeDef schemaFieldType)

          where

            schemaFieldType = resolve fieldType

            fieldMetadata = Metadata fieldName Nothing (attr fieldAttributes) modifier

                (defaultValue schemaFieldType <$> fieldDefault)

            modifier = case fieldModifier of

                Optional -> Nothing

                Required -> Just 1

                RequiredOptional -> Just 2

            defaultValue BT_WString (DefaultString x) = variant {wstring_value = Just x}

            defaultValue BT_String (DefaultString x)  = variant {string_value = Just x}

            defaultValue t (DefaultFloat x)

                | isFloat t                           = variant {double_value = Just x}

            defaultValue t (DefaultInteger x)

                | isSigned t                          = variant {int_value = Just x}

                | isUnsigned t                        = variant {uint_value = Just x}

                | isFloat t                           = variant {double_value = Just $ fromInteger x}

            defaultValue BT_Maybe{} (DefaultNothing)  = variant {nothing = Just True}

            defaultValue BT_Bool (DefaultBool x)      = variant {uint_value = Just $ if x then 1 else 0}

            defaultValue (BT_UserDefined e _) (DefaultEnum x) = variant {int_value = Just $ resolveEnum e x}

            defaultValue _ _ = error $ "makeSchemaDef.defaultValue: invalid default value for field "

                                     ++ structName ++ "." ++ fieldName

    structDef _ = error "makeSchemaDef.structDef: Not a struct type"

    -- TypeDef for specified type

    typeDef typ

        | isScalar typ || isString typ || isMetaName typ

                             = TypeDef (Just $ typeId typ) Nothing Nothing Nothing Nothing

        | otherwise = case typ of

            BT_Blob         -> listDef BT_Int8

            (BT_List t)     -> listDef t

            (BT_Vector t)   -> listDef t

            (BT_Nullable t) -> listDef t

            (BT_Set t)      -> TypeDef (Just 12) Nothing (Just [typeDef t]) Nothing Nothing

            (BT_Map k t)    -> TypeDef (Just 13) Nothing (Just [typeDef t]) (Just [typeDef k]) Nothing

            (BT_Bonded t)   -> (typeDef t) {bonded_type = Just True}

            (BT_Maybe t)    -> typeDef t

            t               -> TypeDef Nothing (Just (structIdx t)) Nothing Nothing Nothing

      where

        listDef t = TypeDef (Just 11) Nothing (Just [typeDef t]) Nothing Nothing

    variant = Variant Nothing Nothing Nothing Nothing Nothing Nothing

    attr [] = Nothing

    attr xs = Just $ concatMap (\a -> [qualifiedName $ attrName a, attrValue a]) xs

    qualifiedName = L.unpack . toLazyText . getQualifiedName ctx

    -- resolve type parameters into type arguments and aliases into aliased types

    resolveType typeParams typeArgs = fmapType resolve

      where

        resolve (BT_TypeParam p) = snd . fromJust $ find ((p ==) . fst) $ zip typeParams typeArgs

        resolve (BT_UserDefined a@Alias{} args) = resolve $ resolveAlias a args

        resolve t = t

    -- resolve value of an enum constant

    resolveEnum Enum{..} n = fromIntegral . snd . fromJust $ find ((n ==) . fst) $ reifyEnumValues enumConstants

    resolveEnum _ _ = error "makeSchemaDef.resolveEnum: not a enum"



$(deriveToJSON defaultOptions {omitNothingFields = True} ''SchemaDef)

$(deriveToJSON defaultOptions {omitNothingFields = True} ''StructDef)

$(deriveToJSON defaultOptions {omitNothingFields = True, fieldLabelModifier = dropWhile ('_' ==)} ''FieldDef)

$(deriveToJSON defaultOptions {omitNothingFields = True} ''TypeDef)

$(deriveToJSON defaultOptions {omitNothingFields = True} ''Metadata)

$(deriveToJSON defaultOptions {omitNothingFields = True} ''Variant)