Type level / Generic programming HS -> TS magic

Instances.hs

deriving instance Generic UIConfig
instance AesonOptions UIConfig
instance S.Generic UIConfig
instance S.HasDatatypeInfo UIConfig
instance TS.TypeScript UIConfig 
--------------------------------------------
-- Instance above errors with:
--  No instance for (Data.Aeson.TypeScript.GTypeBody
--                     '[ '[UIConfigV001], '[[Char]]]
--                     ('Generics.SOP.Type.Metadata.ADT
--                         "Lisa.Init.UIConfig.Main"
--                         "UIConfig"
--                         '[ 'Generics.SOP.Type.Metadata.Constructor "V001",
--                         'Generics.SOP.Type.Metadata.Constructor "Unknown"]
--                         '[ '[ 'Generics.SOP.Type.Metadata.StrictnessInfo
--                                 'GHC.Generics.NoSourceUnpackedness
--                                 'GHC.Generics.NoSourceStrictness
--                                 'GHC.Generics.DecidedLazy],
--                         '[ 'Generics.SOP.Type.Metadata.StrictnessInfo
--                                 'GHC.Generics.NoSourceUnpackedness
--                                 'GHC.Generics.NoSourceStrictness
--                                 'GHC.Generics.DecidedLazy]]))
--     arising from a use of ‘Data.Aeson.TypeScript.$dmtsTypeBody’
-- • In the expression:
--     Data.Aeson.TypeScript.$dmtsTypeBody @(UIConfig)
-- In an equation for ‘tsTypeBody’:
--     tsTypeBody = Data.Aeson.TypeScript.$dmtsTypeBody @(UIConfig)
-- In the instance declaration for ‘TypeScript UIConfig’ (lsp)
--------------------------------------------

deriving instance Generic UIConfigV001
instance AesonOptions UIConfigV001
instance S.Generic UIConfigV001
instance S.HasDatatypeInfo UIConfigV001
instance TS.TypeScript UIConfigV001

deriving instance Generic Rest
instance AesonOptions Rest
instance S.Generic Rest
instance S.HasDatatypeInfo Rest
instance TS.TypeScript Rest

deriving instance Generic Auth
instance AesonOptions Auth
instance S.Generic Auth
instance S.HasDatatypeInfo Auth
instance TS.TypeScript Auth

deriving instance Generic Graphql
instance AesonOptions Graphql
instance S.Generic Graphql
instance S.HasDatatypeInfo Graphql
instance TS.TypeScript Graphql

deriving instance Generic ExternalId
instance AesonOptions ExternalId
instance S.Generic ExternalId
instance S.HasDatatypeInfo ExternalId
instance TS.TypeScript ExternalId

deriving instance Generic Search
instance AesonOptions Search
instance S.Generic Search
instance S.HasDatatypeInfo Search
instance TS.TypeScript Search

deriving instance Generic Crud
instance AesonOptions Crud
instance S.Generic Crud
instance S.HasDatatypeInfo Crud
instance TS.TypeScript Crud

deriving instance Generic SpeakerLabels
instance AesonOptions SpeakerLabels
instance S.Generic SpeakerLabels
instance S.HasDatatypeInfo SpeakerLabels
instance TS.TypeScript SpeakerLabels

deriving instance Generic WhiteLabel
instance AesonOptions WhiteLabel
instance S.Generic WhiteLabel
instance S.HasDatatypeInfo WhiteLabel

TS.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

module Data.Aeson.TypeScript (
    TypeScript (..)
  , TsDeclaration, TsTypeInfo (..), TsTypeBody (..)
  , NullaryCon
  , mkTypeInfo
  , renderTsDeclaration, tsDeclaration, tsTypeName
  ) where

import qualified Data.Aeson                 as A
import           Data.Aeson.Via             (AesonOptions (..))
import           Data.Kind                  (Type)
import           Generics.SOP               hiding (fieldName)
import           Generics.SOP.NP            (collapse_NP, cpure_NP, map_NP)
import qualified Generics.SOP.Type.Metadata as M
import           RIO                        hiding (Generic)
import qualified RIO.Text                   as T

{-# ANN module ("hlint: ignore Use if" :: String) #-}

data TsDeclaration = TsDeclaration
    { typeInfo :: TsTypeInfo
    , typeBody :: TsTypeBody
    }
-----------------------------------------------
-- I've added EnumWithType [TsDeclaration]
-----------------------------------------------
data TsTypeBody = Alias Text | Struct [StructField] | Enum [Text] | EnumWithType [TsDeclaration]

data TsTypeInfo = TsTypeInfo
    { typeInfoName      :: Text
    , typeLikeMaybe     :: Bool
    , omitNothingFields :: Bool
    }

mkTypeInfo :: Text -> TsTypeInfo
mkTypeInfo n = TsTypeInfo n False True

data StructField = StructField
    { fieldName     :: Text
    , fieldTypeInfo :: TsTypeInfo
    }

class TypeScript a where
    tsTypeInfo :: Proxy a -> TsTypeInfo
    default tsTypeInfo :: (HasDatatypeInfo a, AesonOptions a) => Proxy a -> TsTypeInfo
    tsTypeInfo = genericTsTypeInfo
    tsTypeBody :: Proxy a -> Maybe TsTypeBody
    default tsTypeBody
        :: (Generic a, HasDatatypeInfo a, AesonOptions a, GTypeBody (Code a) (DatatypeInfoOf a))
        => Proxy a -> Maybe TsTypeBody
    tsTypeBody _ = Just $ gTypeBody (Proxy @(Code a)) (Proxy @(DatatypeInfoOf a))

tsDeclaration :: TypeScript a => Proxy a -> Maybe TsDeclaration
tsDeclaration p = TsDeclaration (tsTypeInfo p) <$> tsTypeBody p

tsTypeName :: TypeScript a => Proxy a -> Text
tsTypeName = typeInfoName . tsTypeInfo

renderTsDeclaration :: TsDeclaration -> Text
renderTsDeclaration TsDeclaration{typeInfo, typeBody} = case typeBody of
    Alias t -> "export type " <> typeName <> " = " <> t <> ";"
    Struct fs -> "export interface " <> typeName <> " {\n" <>
        T.intercalate "\n" (renderField <$> fs) <>
        "\n};"
    Enum es -> "export enum " <> typeName <> "Enum {\n" <>
        T.intercalate "\n" (renderEnum <$> es) <>
        "\n};\n\nexport type " <> typeName <> " = keyof typeof " <> typeName <> "Enum;"
---------------------------------------------------
-- and here to deal with the recursion of the types
---------------------------------------------------
    EnumWithType ets -> "export enum " <> typeName <> "Enum {\n" <>
        T.intercalate "\n" (renderTsDeclaration <$> ets) <>
        "\n};\n\nexport type " <> typeName <> " = keyof typeof " <> typeName <> "Enum;"

  where
    typeName = typeInfoName typeInfo
    renderField sf = "  " <> fieldName sf <> bdy <> ";"
      where
        info = fieldTypeInfo sf
        bdy = case typeLikeMaybe info of
            False -> ": " <> typeInfoName info
            True  -> case omitNothingFields typeInfo of
                True  -> "?: " <> typeInfoName info
                False -> ": " <> typeInfoName info <> " | null"
    renderEnum e = "  " <> e <> " = \"" <> e <> "\","

class GTypeBody (code :: [[Type]]) (info :: M.DatatypeInfo) where
    gTypeBody :: Proxy code -> Proxy info -> TsTypeBody

-- | Record types become TypeScript structs.
instance (All TypeScript ri, M.DemoteFieldInfos fi ri)
    => GTypeBody '[ri] ('M.ADT mn dn '[ 'M.Record cn fi] si) where

    gTypeBody _ _ = Struct $ toSF <$> zip
        (collapse_NP $ cpure_NP @TypeScript @ri Proxy getInfo)
        (collapse_NP $ map_NP (\(FieldInfo n) -> K n) fis)
      where
        fis = M.demoteFieldInfos @fi @ri Proxy
        getInfo :: forall x. TypeScript x => K TsTypeInfo x
        getInfo = K $ tsTypeInfo (Proxy @x)
        toSF :: (TsTypeInfo, String) -> StructField
        toSF (fieldTypeInfo, fieldName) = StructField
            { fieldName = T.pack fieldName
            , fieldTypeInfo
            }

-- | All-nullary types become TypeScript enums.
instance (AllZip NullaryCon ('[] : es) cs, M.DemoteConstructorInfos cs ('[] : es))
    => GTypeBody ('[] : es) ('M.ADT mn dn cs si) where

    gTypeBody _ _ = Enum $ collapse_NP $ map_NP conName $
        M.demoteConstructorInfos @cs @('[] : es) Proxy
      where
        conName :: ConstructorInfo a -> K Text a
        conName = K . T.pack . constructorName

-- | Enforce that a constructor is nullary (takes no values).
class NullaryCon (t :: [Type]) (con :: M.ConstructorInfo) where
instance NullaryCon t ('M.Constructor x) where
--------------------------------------------------------------
-- above used to be `instance NullaryCon `[] ('M.Constructor x) where`
-- which I think enforced any iditianal types to a sum type constructor 
-- to be ignore
--------------------------------------------------------------
genericTsTypeInfo :: (HasDatatypeInfo a, AesonOptions a) => Proxy a -> TsTypeInfo
genericTsTypeInfo p = TsTypeInfo
    { typeInfoName      = T.pack . datatypeName $ datatypeInfo p
    , typeLikeMaybe     = False
    , omitNothingFields = A.omitNothingFields $ aesonOptions p
    }

builtin :: Text -> Proxy a -> TsTypeInfo
builtin n _ = TsTypeInfo n False True

instance TypeScript Int where
    tsTypeInfo = builtin "number"
    tsTypeBody _ = Nothing

instance TypeScript Char where
    tsTypeInfo = builtin "string"
    tsTypeBody _ = Nothing

instance TypeScript Double where
    tsTypeInfo = builtin "number"
    tsTypeBody _ = Nothing

instance TypeScript Text where
    tsTypeInfo = builtin "string"
    tsTypeBody _ = Nothing

instance TypeScript Bool where
    tsTypeInfo = builtin "boolean"
    tsTypeBody _ = Nothing

instance (TypeScript a) => TypeScript (Maybe a) where
    tsTypeInfo _ = (tsTypeInfo (Proxy @a)){typeLikeMaybe = True}
    tsTypeBody _ = Nothing

instance (TypeScript a) => TypeScript [a] where
    tsTypeInfo _ = ti{ typeInfoName = typeInfoName ti <> "[]" }
      where ti = tsTypeInfo (Proxy @a)
    tsTypeBody _ = Nothing

instance (TypeScript a) => TypeScript (Vector a) where
    tsTypeInfo _ = ti{ typeInfoName = typeInfoName ti <> "[]" }
      where ti = tsTypeInfo (Proxy @a)
    tsTypeBody _ = Nothing

instance (TypeScript a) => TypeScript (NonEmpty a) where
    tsTypeInfo _ = ti{ typeInfoName = typeInfoName ti <> "[]" }
      where ti = tsTypeInfo (Proxy @a)
    tsTypeBody _ = Nothing

TypesFromLibrary.hs

data UIConfigV001 = UIConfigV001
    { version               :: Int
    , rest                  :: Rest
    , auth                  :: Auth
    , graphql               :: Graphql
    , externalId            :: ExternalId
    , search                :: Search
    , speakerLabels         :: SpeakerLabels
    , teamManagement        :: Crud
    , callLabels            :: Crud
    , callDrivers           :: Visibility
    , downloads             :: Visibility
    , customMetadata        :: Visibility
    , customDataForm        :: Crud
    , whiteLabel            :: WhiteLabel
    , hideScorecardForAgent :: Bool
    } deriving (Eq, Show)

data Rest = Rest
    { uri       :: Text
    , audioPath :: Text
    } deriving (Eq, Show)

data Auth = Auth
    { loginUrl  :: Text
    , logoutUrl :: Text
    } deriving (Eq, Show)

data Graphql = Graphql
    { uri            :: Text
    , persistedQuery :: Bool
    } deriving (Eq, Show)

data ExternalId = ExternalId
    { match   :: Text
    , replace :: Text
    } deriving (Eq, Show)

data Search = Search
    { grouping :: Bool
    , customer :: Bool
    } deriving (Eq, Show)

data Crud = Crud
    { visibility       :: Visibility
    , editPermission   :: Visibility
    , createPermission :: Visibility
    , deletePermission :: Visibility
    } deriving (Eq, Show)

data SpeakerLabels = SpeakerLabels
    { agent  :: Text
    , caller :: Text
    } deriving (Eq, Show)

data WhiteLabel
    = Default
    | Custom Text
    deriving (Eq, Show)

data Visibility
    = Everyone
    | CustomerAdmin
    | DaiseeEmployee
    | Hidden
    | Agent
    deriving (Eq, Show)