content: -- 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)
  