Skip to content

Instantly share code, notes, and snippets.

@Cmdv
Last active October 15, 2021 10:07
Show Gist options
  • Save Cmdv/2af2b3f56b7343b82b26b5c7761675ee to your computer and use it in GitHub Desktop.
Save Cmdv/2af2b3f56b7343b82b26b5c7761675ee to your computer and use it in GitHub Desktop.
Type level / Generic programming HS -> TS magic
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
{-# 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
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment