Type.hs

{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
-- | Union types describing JSON objects, and operations for querying these types.
module Data.Aeson.AutoType.Type(typeSize,
                                Dict(..), keys, get, withDict,
                                Type(..), emptyType,
                                isSimple, isArray, isObject, typeAsSet,
                                hasNonTopTObj,
                                hasTObj,
                                isNullable,
                                emptySetLikes
  ) where

import           Prelude             hiding (any)
import qualified Data.HashMap.Strict as Hash
import qualified Data.Set            as Set
import           Data.Data          (Data(..))
import           Data.Typeable      (Typeable)
import           Data.Foldable      (any)
import           Data.Text          (Text)
import           Data.Set           (Set )
import           Data.HashMap.Strict(HashMap)
import           Data.List          (sort)
import           Data.Ord           (comparing)
import           Data.Generics.Uniplate
import           Text.PrettyPrint.GenericPretty

import           Data.Aeson.AutoType.Pretty ()

-- * Dictionary types for overloading of usual class instances.
-- | Type alias for HashMap
type Map = HashMap

-- | Dictionary of types indexed by names.
newtype Dict = Dict { unDict :: Map Text Type }
  deriving (Eq, Data, Typeable, Generic)

instance Out Dict where
  doc       = doc       . unDict
  docPrec p = docPrec p . unDict

instance Show Dict where
  show = show . sort . Hash.toList . unDict

instance Ord Dict where
  compare = comparing $ sort . Hash.toList . unDict

-- | Make operation on a map to an operation on a Dict.
withDict :: (Map Text Type -> Map Text Type) -> Dict -> Dict
f `withDict` (Dict m) = Dict $ f m

-- | Take all keys from dictionary.
keys :: Dict -> Set Text
keys = Set.fromList . Hash.keys . unDict

-- | Union types for JSON values.
data Type = TNull | TBool | TString        |
            TInt  | TDouble                |
            TUnion (Set      Type)         |
            TLabel  Text                   |
            TObj    Dict                   |
            TArray  Type
  deriving (Show,Eq, Ord, Data, Typeable, Generic)

instance Out Type

-- These are missing Uniplate instances...
{-
instance Biplate (Set a) a where
  biplate s = (Set.toList s, Set.fromList)

instance Biplate (HashMap k v) v where
  biplate m = (Hash.elems m, Hash.fromList . zip (Hash.keys m))
 -}

instance Uniplate Type where
  uniplate (TUnion s) = (Set.toList s, TUnion .        Set.fromList                     )
  uniplate (TObj   d) = (Hash.elems m, TObj   . Dict . Hash.fromList . zip (Hash.keys m))
    where
      m = unDict d
  uniplate (TArray t) = ([t],          TArray . head  )
  uniplate s          = ([],           const s        )

-- | Empty type
emptyType :: Type
emptyType = TUnion Set.empty

-- | Lookup the Type within the dictionary.
get :: Text -> Dict -> Type
get key = Hash.lookupDefault TNull key . unDict

-- $derive makeUniplateDirect ''Type

-- | Size of the `Type` term.
typeSize           :: Type -> Int
typeSize TNull      = 1
typeSize TBool      = 1
typeSize TString    = 1
typeSize TInt       = 1
typeSize TDouble    = 1
typeSize (TObj   o) = (1+) . sum     . map typeSize . Hash.elems . unDict $ o
typeSize (TArray a) = 1 + typeSize a
typeSize (TUnion u) = (1+) . sum . (0:) . map typeSize . Set.toList $ u
typeSize (TLabel _) = error "Don't know how to compute typeSize of TLabel."

-- | Check if this is nullable (Maybe) type, or not.
-- Nullable type will always accept TNull or missing key that contains it.
isNullable :: Type -> Bool
isNullable  TNull     = True
isNullable (TUnion u) = isNullable `any` u
isNullable  _         = False

-- | "Null-ish" types
emptySetLikes ::  Set Type
emptySetLikes = Set.fromList [TNull, TArray $ TUnion $ Set.fromList []]
-- Q: and TObj $ Map.fromList []?
{-# INLINE emptySetLikes #-}

-- | Convert any type into union type (even if just singleton).
typeAsSet :: Type -> Set Type
typeAsSet (TUnion s) = s
typeAsSet t          = Set.singleton t

-- | Is the top-level constructor a TObj?
isObject         :: Type -> Bool
isObject (TObj _) = True
isObject _        = False

-- | Is it a simple (non-compound) Type?
isSimple  :: Type -> Bool
isSimple x = not (isObject x) && not (isArray x) && not (isUnion x)

-- | Is the top-level constructor a TUnion?
isUnion           :: Type -> Bool
isUnion (TUnion _) = True
isUnion _          = False

-- | Is the top-level constructor a TArray?
-- | Check if the given type has non-top TObj.
isArray           :: Type -> Bool
isArray (TArray _) = True
isArray _          = False

-- | Check if the given type has non-top TObj.
hasNonTopTObj         :: Type -> Bool
hasNonTopTObj (TObj o) = any hasTObj $ Hash.elems $ unDict o
hasNonTopTObj _        = False

-- | Check if the given type has TObj on top or within array..
hasTObj           :: Type -> Bool
hasTObj (TObj   _) = True
hasTObj (TArray a) = hasTObj a
hasTObj (TUnion u) = any hasTObj u
hasTObj _          = False