Instances.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- Note: the OverlappingInstances pragma is only here so the overlapping instances in this file
-- will work on older GHCs, like GHC 7.8.4

module Data.Aeson.TypeScript.Instances where

import qualified Data.Aeson as A
import Data.Aeson.TypeScript.Types
import Data.Data
import Data.Functor.Compose (Compose)
import Data.Functor.Const (Const)
import Data.Functor.Identity (Identity)
import Data.Functor.Product (Product)
import Data.HashMap.Strict
import Data.HashSet
import Data.Kind (Type)
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict
import Data.Set
import Data.String.Interpolate
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Void
import Data.Word
import GHC.Int
import Numeric.Natural (Natural)

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as A
#endif


instance TypeScript () where
  getTypeScriptType _ = "void"

instance TypeScript Void where
  getTypeScriptType _ = "void"

instance TypeScript T.Text where
  getTypeScriptType _ = "string"

instance TypeScript TL.Text where
  getTypeScriptType _ = "string"

instance TypeScript Integer where
  getTypeScriptType _ = "number"

instance TypeScript Natural where
  getTypeScriptType _ = "number"

instance TypeScript Float where
  getTypeScriptType _ = "number"

instance TypeScript Double where
  getTypeScriptType _ = "number"

instance TypeScript Bool where
  getTypeScriptType _ = "boolean"

instance TypeScript Int where
  getTypeScriptType _ = "number"

instance TypeScript Int16 where
  getTypeScriptType _ = "number"

instance TypeScript Int32 where
  getTypeScriptType _ = "number"

instance TypeScript Int64 where
  getTypeScriptType _ = "number"

instance TypeScript Char where
  getTypeScriptType _ = "string"

instance TypeScript Word where
  getTypeScriptType _ = "number"

instance TypeScript Word8 where
  getTypeScriptType _ = "number"

instance TypeScript Word16 where
  getTypeScriptType _ = "number"

instance TypeScript Word32 where
  getTypeScriptType _ = "number"

instance TypeScript Word64 where
  getTypeScriptType _ = "number"

instance {-# OVERLAPPABLE #-} (TypeScript a) => TypeScript [a] where
  getTypeScriptType _ = (getTypeScriptType (Proxy :: Proxy a)) ++ "[]"
  getParentTypes _ = [TSType (Proxy :: Proxy a)]

instance (TypeScript a) => TypeScript (NonEmpty a) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy [a])
  getParentTypes _ = [TSType (Proxy :: Proxy a)]

instance {-# OVERLAPPING #-} TypeScript [Char] where
  getTypeScriptType _ = "string"

instance (TypeScript a, TypeScript b) => TypeScript (Either a b) where
  getTypeScriptType _ = [i|Either<#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}>|]
  getTypeScriptDeclarations _ = [TSTypeAlternatives "Either" ["T1", "T2"] ["Left<T1>", "Right<T2>"] Nothing
                               , TSInterfaceDeclaration "Left" ["T"] [TSField False "Left" "T" Nothing] Nothing
                               , TSInterfaceDeclaration "Right" ["T"] [TSField False "Right" "T" Nothing] Nothing
                               ]
  getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy a))
                           , (TSType (Proxy :: Proxy b))
                           ]

instance (TypeScript a, TypeScript b) => TypeScript (a, b) where
  getTypeScriptType _ = [i|[#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}]|]
  getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy a))
                           , (TSType (Proxy :: Proxy b))
                           ]

instance (TypeScript a, TypeScript b, TypeScript c) => TypeScript (a, b, c) where
  getTypeScriptType _ = [i|[#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}, #{getTypeScriptType (Proxy :: Proxy c)}]|]
  getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy a))
                           , (TSType (Proxy :: Proxy b))
                           , (TSType (Proxy :: Proxy c))
                           ]

instance (TypeScript a, TypeScript b, TypeScript c, TypeScript d) => TypeScript (a, b, c, d) where
  getTypeScriptType _ = [i|[#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}, #{getTypeScriptType (Proxy :: Proxy c)}, #{getTypeScriptType (Proxy :: Proxy d)}]|]
  getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy a))
                           , (TSType (Proxy :: Proxy b))
                           , (TSType (Proxy :: Proxy c))
                           , (TSType (Proxy :: Proxy d))
                           ]

instance forall a k (b :: k). (Typeable k, Typeable b, TypeScript a) => TypeScript (Const a b) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a)
  getParentTypes _ = [TSType (Proxy :: Proxy a)]

instance (TypeScript a) => TypeScript (Identity a) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a)
  getParentTypes _ = [TSType (Proxy :: Proxy a)]

instance forall k k1 (f :: k -> Type) (g :: k1 -> k) a. (
  Typeable k, Typeable k1, Typeable f, Typeable g, Typeable a, TypeScript (f (g a)), TypeScript a
  ) => TypeScript (Compose f g a) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy (f (g a)))
  getParentTypes _ = getParentTypes (Proxy :: Proxy (f (g a)))

instance forall k (f :: k -> Type) (g :: k -> Type) a. (
  Typeable k, Typeable f, Typeable g, Typeable a, TypeScript (f a), TypeScript (g a)
  ) => TypeScript (Product f g a) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy (f a, g a))
  getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy (f a)))
                           , (TSType (Proxy :: Proxy (g a)))
                           ]

instance (TypeScript a) => TypeScript (Maybe a) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a)
  getTypeScriptOptional _ = True
  getParentTypes _ = [TSType (Proxy :: Proxy a)]

instance TypeScript A.Value where
  getTypeScriptType _ = "any";

instance (TypeScript a, TypeScript b, A.ToJSONKey a) => TypeScript (Map a b) where
  getTypeScriptType =
    let k = getTypeScriptKeyType @a Proxy
        v = getTypeScriptType @b Proxy
    in const $ case A.toJSONKey @a of
      A.ToJSONKeyText{} -> "{[k in " <> k <> "]?: " <> v <> "}"
      A.ToJSONKeyValue{} -> getTypeScriptType @[(a, b)] Proxy
  getParentTypes = const $ L.nub [TSType @a Proxy, TSType @b Proxy]

instance (TypeScript a, TypeScript b, A.ToJSONKey a) => TypeScript (HashMap a b) where
  getTypeScriptType = const $ getTypeScriptType @(Map a b) Proxy
  getParentTypes = const $ getParentTypes @(Map a b) Proxy

#if MIN_VERSION_aeson(2,0,0)
instance (TypeScript a) => TypeScript (A.KeyMap a) where
  getTypeScriptType _ = [i|{[k: string]: #{getTypeScriptType (Proxy :: Proxy a)}}|]
  getParentTypes _ = L.nub [TSType (Proxy :: Proxy a)]
#endif

instance (TypeScript a) => TypeScript (Set a) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) <> "[]";
  getParentTypes _ = [TSType (Proxy :: Proxy a)]

instance (TypeScript a) => TypeScript (HashSet a) where
  getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) ++ "[]"
  getParentTypes _ = [TSType (Proxy :: Proxy a)]