{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE QuasiQuotes #-}
module Data.Aeson.Generics.TypeScript
( -- * Primary generation functions
getPrintedDefinition
, printTS
-- * Type Classes
, FieldTypeName (..)
, TypeScriptDefinition (..)
-- * TypeScript AST data types
, FieldSpec (..)
, FieldType (..)
, IsNewtype (..)
, TSField (..)
, TSGenericVar
, TSInterface (..)
, TSType (..)
-- * Convenience builders
, concretely
, genericly
) where
import Data.Char (toUpper)
import Data.Containers.ListUtils (nubOrd)
import Data.Data (Proxy (..))
import Data.Kind (Constraint, Type)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty, toList)
import Data.Map (Map)
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.String.Interpolate (i)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import GHC.Generics
( C1
, D1
, Generic (Rep)
, Meta (MetaCons, MetaData, MetaSel)
, Rec0
, S1
, U1
, type (:*:)
, type (:+:)
)
import GHC.TypeLits
( ErrorMessage (ShowType, Text, (:$$:), (:<>:))
, KnownSymbol
, Symbol
, TypeError
, symbolVal
)
-- | Type level rep of a named generic type variable
type TSGenericVar :: Symbol -> Type
data TSGenericVar s
-- | Determine if this is a newtype and will not be wrapped
type IsNewtype :: Type
data IsNewtype
= Newtype
| Oldtype
deriving stock (Eq, Ord, Show)
-- | The top level TypeScript type declaration
type TSType :: Type
data TSType = TSType
{ tst_constructor :: !String
, tst_doc :: !String
, tst_interfaces :: !(NonEmpty TSInterface)
, tst_newtype :: !IsNewtype
}
deriving stock (Eq, Ord, Show)
-- | A term constructor in Haskell, most likely an interface in TypeScript
type TSInterface :: Type
data TSInterface = TSInterface
{ tsi_constructor :: !String
, tsi_typeName :: !(Maybe String)
, tsi_members :: ![TSField]
}
deriving stock (Eq, Ord, Show)
-- | Fields can be concrete types, or generic type variables
type FieldType :: Type
data FieldType
= GenericField
| ConcreteField
deriving stock (Bounded, Enum, Eq, Ord, Show)
instance Semigroup FieldType where
GenericField <> _ = GenericField
_ <> GenericField = GenericField
_ <> _ = ConcreteField
-- | A field within a term constructor
type TSField :: Type
data TSField = TSField
{ fieldName :: !(Maybe String)
, fieldType :: !FieldSpec
}
deriving stock (Eq, Ord, Show)
-- | Helper for printing fields
type FieldSpec :: Type
data FieldSpec = FieldSpec
{ fs_type :: !FieldType
, fs_wrapped :: !String
, fs_unwrapped :: !String
}
deriving stock (Eq, Ord, Show)
-- | Construct a FieldSpec assuming standard use and a concrete type variable
concretely :: String -> FieldSpec
concretely x = FieldSpec ConcreteField x x
-- | Construct a FieldSpec assuming standard use and a generic type variable
genericly :: String -> FieldSpec
genericly x = FieldSpec GenericField x x
-- | Typeclass to determine the FieldSpec from a payload's type
type FieldTypeName :: a -> Constraint
class FieldTypeName a where
fieldTypeName :: Proxy a -> FieldSpec
-- | Lists are Arrays according to Aeson
instance FieldTypeName a => FieldTypeName [a] where
fieldTypeName _ = let
FieldSpec t wrapped unwrapped = fieldTypeName $ Proxy @a
in FieldSpec t ("Array<" <> wrapped <> ">") unwrapped
-- | Handle wrapped payload
instance FieldTypeName a => FieldTypeName (Rec0 a) where
fieldTypeName _ = fieldTypeName $ Proxy @a
-- | This needs to overlap so it doesn't get treated as an Array
instance {-# OVERLAPS #-} FieldTypeName String where
fieldTypeName _ = concretely "string"
instance FieldTypeName UTCTime where
fieldTypeName _ = concretely "string"
instance FieldTypeName T.Text where
fieldTypeName _ = concretely "string"
instance (FieldTypeName a, FieldTypeName b) => FieldTypeName (Either a b) where
fieldTypeName _ =
let a = fieldTypeName (Proxy @a)
b = fieldTypeName (Proxy @b)
eType l r = [i|{ Left: #{l} } | { Right: #{r} }|]
in FieldSpec (fs_type a <> fs_type b) (fs_wrapped a `eType` fs_wrapped b) (fs_unwrapped a `eType` fs_unwrapped b)
instance (FieldTypeName a, FieldTypeName b) => FieldTypeName (Map a b) where
fieldTypeName _ = FieldSpec (fs_type a <> fs_type b) asMap $ fs_unwrapped a <> "," <> fs_unwrapped b
where
a = fieldTypeName $ Proxy @a
b = fieldTypeName $ Proxy @b
wrappedB = fs_wrapped b
asMap = [i|{ [key: string]: #{wrappedB} }|]
instance FieldTypeName Int where fieldTypeName _ = concretely "number"
instance FieldTypeName Integer where fieldTypeName _ = concretely "number"
instance FieldTypeName Float where fieldTypeName _ = concretely "number"
instance FieldTypeName Bool where fieldTypeName _ = concretely "boolean"
instance FieldTypeName a => FieldTypeName (Maybe a) where
fieldTypeName _ = inner { fs_wrapped = fs_wrapped inner <> " | null" }
where inner = fieldTypeName (Proxy @a)
instance FieldTypeName () where
fieldTypeName _ = concretely "[]"
instance {-# OVERLAPPABLE #-} TypeScriptDefinition a => FieldTypeName a where
fieldTypeName _ = let x = gen @a in ly x $ tst_constructor x where
ly TSType {..} = if any ((== GenericField) . fs_type . fieldType) . mconcat . toList $ tsi_members <$> tst_interfaces
then genericly else concretely
instance KnownSymbol s => FieldTypeName (TSGenericVar s) where
fieldTypeName _ = genericly . cap . symbolVal $ Proxy @s
where cap (x:xs) = toUpper x : xs
cap [] = []
-- | This typeclass provides the ability to derive a TSType from any Generic data type
type TypeScriptDefinition :: Type -> Constraint
class TypeScriptDefinition a where
gen :: TSType
default gen ::
( TSType ~ GTypeScriptTail (Rep a)
, GTypeScriptDef (Rep a)) => TSType
gen = ggen $ Proxy @(Rep a)
-- | Custom error for missing TypeScriptDefinition's, as they can be a red herring
instance TypeError
('Text "No instance of TypeScriptDefinition found for: " ':<>: 'ShowType a ':$$:
'Text "💠 If you are seeing this for a newtype of something primitive, derive FieldTypeName instead.") => TypeScriptDefinition a where
gen = error "unreachable"
-- | Generic deriving mechanism for TypeScriptDefinition
type GTypeScriptDef :: a -> Constraint
class GTypeScriptDef a where
type GTypeScriptTail a :: Type
ggen :: Proxy a -> GTypeScriptTail a
-- | This is the top level of the Generic structure, D1, which holds top level 'Metadata
instance
( KnownSymbol name
, KnownSymbol module'
, KnownSymbol package
, GTypeScriptDef u
, GTypeScriptTail u ~ NonEmpty TSInterface
, isNew `DegradesTo` Bool
) => GTypeScriptDef (D1 ('MetaData name module' package isNew) u) where
type GTypeScriptTail (D1 ('MetaData name module' package isNew) u) = TSType
ggen _ = TSType
(symbolVal (Proxy @name))
("Defined in " <> symbolVal (Proxy @module') <> " of " <> symbolVal (Proxy @package))
(ggen (Proxy @u))
(if degrade (Proxy @isNew) then Newtype else Oldtype)
-- | Handler for Generic constructors, which we convert to @TSInterfaces@
instance
( KnownSymbol name
, GTypeScriptDef u
, GTypeScriptTail u ~ [TSField]
) => GTypeScriptDef (C1 ('MetaCons name fixity hasNames) u) where
type GTypeScriptTail (C1 ('MetaCons name fixity hasNames) u) = NonEmpty TSInterface
ggen _ = pure $ TSInterface (symbolVal (Proxy @name)) Nothing (checkTSFields $ ggen $ Proxy @u)
where
-- Sanity checker @TSField@, this is useful to ensure invariants assumed by JavaScript objects
checkTSFields ts = let
uniqueFieldNames = nubOrd $ fieldName <$> ts
in if length uniqueFieldNames /= length ts
&& not (all (isNothing . fieldName) ts)
then error $ "record field names are not unique : " <> show ts
else ts
instance GTypeScriptDef U1 where
type GTypeScriptTail U1 = [TSField]
ggen _ = []
instance
( FieldTypeName u, w `DegradesTo` Maybe String
)=> GTypeScriptDef (S1 ('MetaSel w x y z) u) where
type GTypeScriptTail (S1 ('MetaSel w x y z) u) = [TSField]
ggen _ = pure $ TSField
{ fieldName = degrade $ Proxy @w
, fieldType = fieldTypeName $ Proxy @u
}
instance
( GTypeScriptTail x ~ NonEmpty TSInterface
, GTypeScriptTail y ~ NonEmpty TSInterface
, GTypeScriptDef x, GTypeScriptDef y
) => GTypeScriptDef (x :+: y) where
type GTypeScriptTail (x :+: y) = NonEmpty TSInterface
ggen _ = ggen (Proxy @x) <> ggen (Proxy @y)
instance
( GTypeScriptTail a ~ [TSField]
, GTypeScriptTail b ~ [TSField]
, GTypeScriptDef a, GTypeScriptDef b
) => GTypeScriptDef (a :*: b) where
type GTypeScriptTail (a :*: b) = [TSField]
ggen _ = ggen (Proxy @a) <> ggen (Proxy @b)
printTS :: TSType -> String
printTS TSType{..} =
[i|// #{tst_doc}
#{typeDecl}|] <> if isEnum || isPureProduct then "" else
(if isSingleRecord then id else mappend "\n") interfaces
where
-- All the type variables found
vars :: [TSField]
vars = mconcat . toList $ tsi_members <$> tst_interfaces
-- The generic variables in TypeScript syntax IE <A,B>
-- These must be unique
generics :: String
generics = mkGenericVars $ nubOrd vars
-- The constructors of the original haskell data type as our AST
constructors :: [(String, [TSField])]
constructors = toList $ (\x -> (tsi_constructor x,tsi_members x)) <$> tst_interfaces
-- The interfaces associated with the constructors in TypeScript syntax
interfaces :: String
interfaces = if null tst_interfaces then "" else
intercalate "\n" . toList $ printTSInterface . hackInTypeName <$> tst_interfaces
-- Is this going to be a special variant for Aeson?
isUnit, isSingleRecord, isPureProduct, isEnum :: Bool
isUnit = length constructors == 1 && isEnum
isSingleRecord = length constructors == 1 && all (all (isJust . fieldName) . tsi_members) tst_interfaces
isPureProduct = length constructors == 1
&& all (all (isNothing . fieldName) . tsi_members) tst_interfaces
isEnum = all (\TSInterface{..} -> null tsi_members) tst_interfaces
-- When we are in a single record context, the interface gets named as the
-- name of the type, not after the term constructor like normal. So we hack it in with an override
hackInTypeName :: TSInterface -> TSInterface
hackInTypeName face = if isSingleRecord then face { tsi_typeName = Just tst_constructor } else face
-- The declaration of the type, if not a single record (which is just the inner interface)
typeDecl :: String
typeDecl = if isSingleRecord && not isUnit then "" :: String else
[i|type #{tst_constructor}#{generics} = #{transObj};|] where
transObj
-- Aeson says so
| isUnit = "[]"
-- Its a newtype
| tst_newtype == Newtype = case vars of
[TSField {..}] -> fs_wrapped fieldType
_ -> error $ "newtype wrong number of fields: " <> show vars
-- This is a data type with mulitple fields and only one constructor, and so is a big tuple
| isPureProduct = "[" <> intercalate ", " ((\TSField {..} -> fs_wrapped fieldType) <$> vars) <> "]"
-- Its a union type
| otherwise = intercalate " | "
. fmap (if isEnum then (\x -> "\"" <> x <> "\"") else id)
$ (\(c,ms) -> c <> mkGenericVars ms) <$> constructors
printTSInterface :: TSInterface -> String
printTSInterface TSInterface{..} = [i|interface #{typeName}#{generics} {
#{tag}readonly tag: "#{tsi_constructor}";|]
<> (if null contents then "" else "\n" <> contents)
<> "\n}" where
-- The name of the type for use in the top of the interface declaration
-- This is different if we are in a single record context. When we are a single
-- record, the interface needs to be the type name, not the term constructor name
typeName :: String
typeName = fromMaybe tsi_constructor tsi_typeName
-- If we are in the single record context, we leave the constructor name
-- around as a code comment for debugging
tag :: String
tag = if isJust tsi_typeName then "// " else ""
-- Make list of variables for contents
unnamed :: String
unnamed = flip mappend ";" $
if length ms > 1 then "[" <> intercalate ", " ms <> "]" else mconcat ms
where ms = fs_wrapped . fieldType <$> tsi_members
-- Payload of the interface
contents :: String
contents = if isRecord then intercalate "\n" $ namedField <$> tsi_members
else " readonly contents: " <> unnamed
-- Do all fields have names?
isRecord :: Bool
isRecord = all (isJust . fieldName) tsi_members
-- Build one named field
namedField :: TSField -> String
namedField TSField {..} = " readonly " <> fieldName' <> ": " <> fieldType' <> ";"
where fieldName' = fromMaybe (error "field name was not found") fieldName
fieldType' = fs_wrapped fieldType
-- Generics of the system
generics :: String
generics = mkGenericVars tsi_members
mkGenericVars :: [TSField] -> String
mkGenericVars xs = if null vars then "" else "<" <> intercalate "," vars <> ">"
where
vars = mapMaybe (go . fieldType) xs
go = \case x@(FieldSpec GenericField _ _) -> Just $ fs_unwrapped x; _ -> Nothing
-- | degrade :: 'Maybe Symbol -> Maybe String
type Degrade :: k -> Constraint
class Degrade (w :: k) where
type Degraded w :: Type
degrade :: Proxy w -> Degraded w
instance KnownSymbol s => Degrade ('Just s) where
type Degraded ('Just s) = Maybe String
degrade _ = Just $ symbolVal $ Proxy @s
instance Degrade 'Nothing where
type Degraded 'Nothing = Maybe String
degrade _ = Nothing
instance Degrade 'True where
type Degraded 'True = Bool
degrade _ = True
instance Degrade 'False where
type Degraded 'False = Bool
degrade _ = False
instance Degrade 'Newtype where
type Degraded 'Newtype = IsNewtype
degrade _ = Newtype
instance Degrade 'Oldtype where
type Degraded 'Oldtype = IsNewtype
degrade _ = Oldtype
type DegradesTo :: k -> Type -> Constraint
type DegradesTo x t = (Degraded x ~ t, Degrade x)
-- | Get the TypeScriptDefinition as a String
getPrintedDefinition :: forall a. TypeScriptDefinition a => Proxy a -> String
getPrintedDefinition _ = printTS $ gen @a
-- This is present as debugging tool
type Foo :: Type -> Type
data Foo a = Foo
| Bar Int
deriving stock (Eq, Generic, Ord, Read, Show)
deriving anyclass (TypeScriptDefinition)