-- 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 #-}



module Language.Bond.Syntax.Util

    ( -- * Type classification

      -- | Functions that test if a type belongs to a particular category. These

      -- functions will resolve type aliases and return answer based on the type

      -- the alias resolves to.

      isScalar

    , isUnsigned

    , isSigned

    , isFloat

    , isString

    , isContainer

    , isList

    , isAssociative

    , isNullable

    , isStruct

    , isEnum

    , isMetaName

      -- * Type mapping

    , fmapType

      -- * Folds

    , foldMapFields

    , foldMapStructFields

    , foldMapType

      -- * Helper functions

    , resolveAlias

    , reifyEnumValues

    ) where



import Data.Maybe

import Data.List

import qualified Data.Foldable as F

import Data.Monoid

import Prelude

import Language.Bond.Util

import Language.Bond.Syntax.Types



-- | Returns 'True' if the type represents a scalar.

isScalar :: Type -> Bool

isScalar BT_Int8 = True

isScalar BT_Int16 = True

isScalar BT_Int32 = True

isScalar BT_Int64 = True

isScalar BT_UInt8 = True

isScalar BT_UInt16 = True

isScalar BT_UInt32 = True

isScalar BT_UInt64 = True

isScalar BT_Float = True

isScalar BT_Double = True

isScalar BT_Bool = True

isScalar (BT_TypeParam (TypeParam _ (Just Value))) = True

isScalar (BT_UserDefined Enum {..} _) = True

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

isScalar _ = False



-- | Returns 'True' if the type represents unsigned integer.

isUnsigned :: Type -> Bool

isUnsigned BT_UInt8 = True

isUnsigned BT_UInt16 = True

isUnsigned BT_UInt32 = True

isUnsigned BT_UInt64 = True

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

isUnsigned _ = False



-- | Returns 'True' if the type represents signed integer.

isSigned :: Type -> Bool

isSigned BT_Int8 = True

isSigned BT_Int16 = True

isSigned BT_Int32 = True

isSigned BT_Int64 = True

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

isSigned _ = False



-- | Returns 'True' if the type represents floating point number.

isFloat :: Type -> Bool

isFloat BT_Float = True

isFloat BT_Double = True

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

isFloat _ = False



-- | Returns 'True' if the type represents a meta-name type.

isMetaName :: Type -> Bool

isMetaName BT_MetaName = True

isMetaName BT_MetaFullName = True

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

isMetaName _ = False



-- | Returns 'True' if the type represents a string.

isString :: Type -> Bool

isString BT_String = True

isString BT_WString = True

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

isString _ = False



-- | Returns 'True' if the type represents a list or a vector.

isList :: Type -> Bool

isList (BT_List _) = True

isList (BT_Vector _) = True

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

isList _ = False



-- | Returns 'True' if the type represents a map or a set.

isAssociative :: Type -> Bool

isAssociative (BT_Set _) = True

isAssociative (BT_Map _ _) = True

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

isAssociative _ = False



-- | Returns 'True' if the type represents a container (i.e. list, vector, set or map).

isContainer :: Type -> Bool

isContainer f = isList f || isAssociative f



-- | Returns 'True' if the type represents a struct or a struct forward declaration.

isStruct :: Type -> Bool

isStruct (BT_UserDefined Struct {} _) = True

isStruct (BT_UserDefined Forward {} _) = True

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

isStruct _ = False



-- | Returns 'True' if the type represents an enum

isEnum :: Type -> Bool

isEnum (BT_UserDefined Enum {} _) = True

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

isEnum _ = False



-- | Returns 'True' if the type represents a nullable type.

isNullable :: Type -> Bool

isNullable (BT_Nullable _) = True

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

isNullable _ = False



-- | Recursively map a 'Type' into another 'Type'.

--

-- ==== __Examples__

--

-- Change lists into vectors:

--

-- > listToVector = fmapType f

-- >  where

-- >    f (BT_List x) = BT_Vector x

-- >    f x = x

fmapType :: (Type -> Type) -> Type -> Type

fmapType f (BT_UserDefined decl args) = f $ BT_UserDefined decl $ map (fmapType f) args

fmapType f (BT_Maybe element) = f $ BT_Maybe $ fmapType f element

fmapType f (BT_Map key value) = f $ BT_Map (fmapType f key) (fmapType f value)

fmapType f (BT_List element) = f $ BT_List $ fmapType f element

fmapType f (BT_Vector element) = f $ BT_Vector $ fmapType f element

fmapType f (BT_Set element) = f $ BT_Set $ fmapType f element

fmapType f (BT_Nullable element) = f $ BT_Nullable $ fmapType f element

fmapType f (BT_Bonded struct) = f $ BT_Bonded $ fmapType f struct

fmapType f x = f x



-- | Maps all fields, including fields of the base, to a 'Monoid', and combines

-- the results. Returns 'mempty' if type is not a struct.

--

-- ==== __Examples__

--

-- Check if there are any container fields:

--

-- > anyContainerFields :: Type -> Bool

-- > anyContainerFields = getAny . foldMapFields (Any . isContainer . fieldType)

foldMapFields :: (Monoid m) => (Field -> m) -> Type -> m

foldMapFields f t = case t of

    (BT_UserDefined   Struct {..} _) -> optional (foldMapFields f) structBase <> F.foldMap f structFields

    (BT_UserDefined a@Alias {..} args) -> foldMapFields f $ resolveAlias a args

    _ -> mempty



-- | Like 'foldMapFields' but takes a 'Declaration' as an argument instead of 'Type'.

foldMapStructFields :: Monoid m => (Field -> m) -> Declaration -> m

foldMapStructFields f s = foldMapFields f $ BT_UserDefined s []



-- | Maps all parts of a 'Type' to a 'Monoid' and combines the results.

--

-- ==== __Examples__

--

-- For a type:

--

-- > list<nullable<int32>>

--

-- the result is:

--

-- >    f (BT_List (BT_Nullable BT_Int32))

-- > <> f (BT_Nullable BT_Int32)

-- > <> f BT_Int32

--

-- 'foldMapType' resolves type aliases. E.g. given the following type alias

-- declaration (Bond IDL syntax):

--

-- > using Array<T, N> = vector<T>;

--

-- the result for the following type:

--

-- > Array<int32, 10>

--

-- is:

--

-- >    f (BT_UserDefined Alias{..} [BT_Int32, BT_IntTypeArg 10])

-- > <> f (BT_Vector BT_Int32)

-- > <> f BT_Int32

foldMapType :: (Monoid m) => (Type -> m) -> Type -> m

foldMapType f t@(BT_UserDefined a@Alias {} args) = f t <> foldMapType f (resolveAlias a args)

foldMapType f t@(BT_UserDefined _ args) = f t <> F.foldMap (foldMapType f) args

foldMapType f t@(BT_Maybe element) = f t <> foldMapType f element

foldMapType f t@(BT_Map key value) = f t <> foldMapType f key <> foldMapType f value

foldMapType f t@(BT_List element) = f t <> foldMapType f element

foldMapType f t@(BT_Vector element) = f t <> foldMapType f element

foldMapType f t@(BT_Set element) = f t <> foldMapType f element

foldMapType f t@(BT_Nullable element) = f t <> foldMapType f element

foldMapType f t@(BT_Bonded struct) = f t <> foldMapType f struct

foldMapType f x = f x





-- | Resolves a type alias declaration with given type arguments. Note that the

-- function resolves one level of aliasing and thus may return a type alias.

resolveAlias :: Declaration -> [Type] -> Type

resolveAlias Alias {..} args = fmapType resolveParam aliasType

  where

    resolveParam (BT_TypeParam param) = snd.fromJust $ find ((param ==).fst) paramsArgs

    resolveParam x = x

    paramsArgs = zip declParams args

resolveAlias _ _ = error "resolveAlias: impossible happened."







-- | Fill in values for constants w/o explicitly specified value

reifyEnumValues :: [Constant] -> [(String, Int)]

reifyEnumValues constants = nameValues 0 constants

  where

    nameValues _ [] = []

    nameValues _ ((Constant name (Just value)):xs) = (name, value) : nameValues (value + 1) xs

    nameValues next ((Constant name Nothing):xs)   = (name, next) : nameValues (next + 1) xs