{-# 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 (IsNewtype -> IsNewtype -> Bool
(IsNewtype -> IsNewtype -> Bool)
-> (IsNewtype -> IsNewtype -> Bool) -> Eq IsNewtype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsNewtype -> IsNewtype -> Bool
== :: IsNewtype -> IsNewtype -> Bool
$c/= :: IsNewtype -> IsNewtype -> Bool
/= :: IsNewtype -> IsNewtype -> Bool
Eq, Eq IsNewtype
Eq IsNewtype
-> (IsNewtype -> IsNewtype -> Ordering)
-> (IsNewtype -> IsNewtype -> Bool)
-> (IsNewtype -> IsNewtype -> Bool)
-> (IsNewtype -> IsNewtype -> Bool)
-> (IsNewtype -> IsNewtype -> Bool)
-> (IsNewtype -> IsNewtype -> IsNewtype)
-> (IsNewtype -> IsNewtype -> IsNewtype)
-> Ord IsNewtype
IsNewtype -> IsNewtype -> Bool
IsNewtype -> IsNewtype -> Ordering
IsNewtype -> IsNewtype -> IsNewtype
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IsNewtype -> IsNewtype -> Ordering
compare :: IsNewtype -> IsNewtype -> Ordering
$c< :: IsNewtype -> IsNewtype -> Bool
< :: IsNewtype -> IsNewtype -> Bool
$c<= :: IsNewtype -> IsNewtype -> Bool
<= :: IsNewtype -> IsNewtype -> Bool
$c> :: IsNewtype -> IsNewtype -> Bool
> :: IsNewtype -> IsNewtype -> Bool
$c>= :: IsNewtype -> IsNewtype -> Bool
>= :: IsNewtype -> IsNewtype -> Bool
$cmax :: IsNewtype -> IsNewtype -> IsNewtype
max :: IsNewtype -> IsNewtype -> IsNewtype
$cmin :: IsNewtype -> IsNewtype -> IsNewtype
min :: IsNewtype -> IsNewtype -> IsNewtype
Ord, Int -> IsNewtype -> ShowS
[IsNewtype] -> ShowS
IsNewtype -> String
(Int -> IsNewtype -> ShowS)
-> (IsNewtype -> String)
-> ([IsNewtype] -> ShowS)
-> Show IsNewtype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsNewtype -> ShowS
showsPrec :: Int -> IsNewtype -> ShowS
$cshow :: IsNewtype -> String
show :: IsNewtype -> String
$cshowList :: [IsNewtype] -> ShowS
showList :: [IsNewtype] -> ShowS
Show)

-- | The top level TypeScript type declaration
type TSType :: Type
data TSType = TSType
  { TSType -> String
tst_constructor :: !String
  , TSType -> String
tst_doc         :: !String
  , TSType -> NonEmpty TSInterface
tst_interfaces  :: !(NonEmpty TSInterface)
  , TSType -> IsNewtype
tst_newtype     :: !IsNewtype
  }
  deriving stock (TSType -> TSType -> Bool
(TSType -> TSType -> Bool)
-> (TSType -> TSType -> Bool) -> Eq TSType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TSType -> TSType -> Bool
== :: TSType -> TSType -> Bool
$c/= :: TSType -> TSType -> Bool
/= :: TSType -> TSType -> Bool
Eq, Eq TSType
Eq TSType
-> (TSType -> TSType -> Ordering)
-> (TSType -> TSType -> Bool)
-> (TSType -> TSType -> Bool)
-> (TSType -> TSType -> Bool)
-> (TSType -> TSType -> Bool)
-> (TSType -> TSType -> TSType)
-> (TSType -> TSType -> TSType)
-> Ord TSType
TSType -> TSType -> Bool
TSType -> TSType -> Ordering
TSType -> TSType -> TSType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TSType -> TSType -> Ordering
compare :: TSType -> TSType -> Ordering
$c< :: TSType -> TSType -> Bool
< :: TSType -> TSType -> Bool
$c<= :: TSType -> TSType -> Bool
<= :: TSType -> TSType -> Bool
$c> :: TSType -> TSType -> Bool
> :: TSType -> TSType -> Bool
$c>= :: TSType -> TSType -> Bool
>= :: TSType -> TSType -> Bool
$cmax :: TSType -> TSType -> TSType
max :: TSType -> TSType -> TSType
$cmin :: TSType -> TSType -> TSType
min :: TSType -> TSType -> TSType
Ord, Int -> TSType -> ShowS
[TSType] -> ShowS
TSType -> String
(Int -> TSType -> ShowS)
-> (TSType -> String) -> ([TSType] -> ShowS) -> Show TSType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TSType -> ShowS
showsPrec :: Int -> TSType -> ShowS
$cshow :: TSType -> String
show :: TSType -> String
$cshowList :: [TSType] -> ShowS
showList :: [TSType] -> ShowS
Show)

-- | A term constructor in Haskell, most likely an interface in TypeScript
type TSInterface :: Type
data TSInterface = TSInterface
  { TSInterface -> String
tsi_constructor :: !String
  , TSInterface -> Maybe String
tsi_typeName    :: !(Maybe String)
  , TSInterface -> [TSField]
tsi_members     :: ![TSField]
  }
  deriving stock (TSInterface -> TSInterface -> Bool
(TSInterface -> TSInterface -> Bool)
-> (TSInterface -> TSInterface -> Bool) -> Eq TSInterface
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TSInterface -> TSInterface -> Bool
== :: TSInterface -> TSInterface -> Bool
$c/= :: TSInterface -> TSInterface -> Bool
/= :: TSInterface -> TSInterface -> Bool
Eq, Eq TSInterface
Eq TSInterface
-> (TSInterface -> TSInterface -> Ordering)
-> (TSInterface -> TSInterface -> Bool)
-> (TSInterface -> TSInterface -> Bool)
-> (TSInterface -> TSInterface -> Bool)
-> (TSInterface -> TSInterface -> Bool)
-> (TSInterface -> TSInterface -> TSInterface)
-> (TSInterface -> TSInterface -> TSInterface)
-> Ord TSInterface
TSInterface -> TSInterface -> Bool
TSInterface -> TSInterface -> Ordering
TSInterface -> TSInterface -> TSInterface
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TSInterface -> TSInterface -> Ordering
compare :: TSInterface -> TSInterface -> Ordering
$c< :: TSInterface -> TSInterface -> Bool
< :: TSInterface -> TSInterface -> Bool
$c<= :: TSInterface -> TSInterface -> Bool
<= :: TSInterface -> TSInterface -> Bool
$c> :: TSInterface -> TSInterface -> Bool
> :: TSInterface -> TSInterface -> Bool
$c>= :: TSInterface -> TSInterface -> Bool
>= :: TSInterface -> TSInterface -> Bool
$cmax :: TSInterface -> TSInterface -> TSInterface
max :: TSInterface -> TSInterface -> TSInterface
$cmin :: TSInterface -> TSInterface -> TSInterface
min :: TSInterface -> TSInterface -> TSInterface
Ord, Int -> TSInterface -> ShowS
[TSInterface] -> ShowS
TSInterface -> String
(Int -> TSInterface -> ShowS)
-> (TSInterface -> String)
-> ([TSInterface] -> ShowS)
-> Show TSInterface
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TSInterface -> ShowS
showsPrec :: Int -> TSInterface -> ShowS
$cshow :: TSInterface -> String
show :: TSInterface -> String
$cshowList :: [TSInterface] -> ShowS
showList :: [TSInterface] -> ShowS
Show)

-- | Fields can be concrete types, or generic type variables
type FieldType :: Type
data FieldType
  = GenericField
  | ConcreteField
  deriving stock (FieldType
FieldType -> FieldType -> Bounded FieldType
forall a. a -> a -> Bounded a
$cminBound :: FieldType
minBound :: FieldType
$cmaxBound :: FieldType
maxBound :: FieldType
Bounded, Int -> FieldType
FieldType -> Int
FieldType -> [FieldType]
FieldType -> FieldType
FieldType -> FieldType -> [FieldType]
FieldType -> FieldType -> FieldType -> [FieldType]
(FieldType -> FieldType)
-> (FieldType -> FieldType)
-> (Int -> FieldType)
-> (FieldType -> Int)
-> (FieldType -> [FieldType])
-> (FieldType -> FieldType -> [FieldType])
-> (FieldType -> FieldType -> [FieldType])
-> (FieldType -> FieldType -> FieldType -> [FieldType])
-> Enum FieldType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: FieldType -> FieldType
succ :: FieldType -> FieldType
$cpred :: FieldType -> FieldType
pred :: FieldType -> FieldType
$ctoEnum :: Int -> FieldType
toEnum :: Int -> FieldType
$cfromEnum :: FieldType -> Int
fromEnum :: FieldType -> Int
$cenumFrom :: FieldType -> [FieldType]
enumFrom :: FieldType -> [FieldType]
$cenumFromThen :: FieldType -> FieldType -> [FieldType]
enumFromThen :: FieldType -> FieldType -> [FieldType]
$cenumFromTo :: FieldType -> FieldType -> [FieldType]
enumFromTo :: FieldType -> FieldType -> [FieldType]
$cenumFromThenTo :: FieldType -> FieldType -> FieldType -> [FieldType]
enumFromThenTo :: FieldType -> FieldType -> FieldType -> [FieldType]
Enum, FieldType -> FieldType -> Bool
(FieldType -> FieldType -> Bool)
-> (FieldType -> FieldType -> Bool) -> Eq FieldType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldType -> FieldType -> Bool
== :: FieldType -> FieldType -> Bool
$c/= :: FieldType -> FieldType -> Bool
/= :: FieldType -> FieldType -> Bool
Eq, Eq FieldType
Eq FieldType
-> (FieldType -> FieldType -> Ordering)
-> (FieldType -> FieldType -> Bool)
-> (FieldType -> FieldType -> Bool)
-> (FieldType -> FieldType -> Bool)
-> (FieldType -> FieldType -> Bool)
-> (FieldType -> FieldType -> FieldType)
-> (FieldType -> FieldType -> FieldType)
-> Ord FieldType
FieldType -> FieldType -> Bool
FieldType -> FieldType -> Ordering
FieldType -> FieldType -> FieldType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FieldType -> FieldType -> Ordering
compare :: FieldType -> FieldType -> Ordering
$c< :: FieldType -> FieldType -> Bool
< :: FieldType -> FieldType -> Bool
$c<= :: FieldType -> FieldType -> Bool
<= :: FieldType -> FieldType -> Bool
$c> :: FieldType -> FieldType -> Bool
> :: FieldType -> FieldType -> Bool
$c>= :: FieldType -> FieldType -> Bool
>= :: FieldType -> FieldType -> Bool
$cmax :: FieldType -> FieldType -> FieldType
max :: FieldType -> FieldType -> FieldType
$cmin :: FieldType -> FieldType -> FieldType
min :: FieldType -> FieldType -> FieldType
Ord, Int -> FieldType -> ShowS
[FieldType] -> ShowS
FieldType -> String
(Int -> FieldType -> ShowS)
-> (FieldType -> String)
-> ([FieldType] -> ShowS)
-> Show FieldType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldType -> ShowS
showsPrec :: Int -> FieldType -> ShowS
$cshow :: FieldType -> String
show :: FieldType -> String
$cshowList :: [FieldType] -> ShowS
showList :: [FieldType] -> ShowS
Show)
instance Semigroup FieldType where
  FieldType
GenericField <> :: FieldType -> FieldType -> FieldType
<> FieldType
_ = FieldType
GenericField
  FieldType
_ <> FieldType
GenericField = FieldType
GenericField
  FieldType
_ <> FieldType
_            = FieldType
ConcreteField

-- | A field within a term constructor
type TSField :: Type
data TSField = TSField
  { TSField -> Maybe String
fieldName :: !(Maybe String)
  , TSField -> FieldSpec
fieldType :: !FieldSpec
  }
  deriving stock (TSField -> TSField -> Bool
(TSField -> TSField -> Bool)
-> (TSField -> TSField -> Bool) -> Eq TSField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TSField -> TSField -> Bool
== :: TSField -> TSField -> Bool
$c/= :: TSField -> TSField -> Bool
/= :: TSField -> TSField -> Bool
Eq, Eq TSField
Eq TSField
-> (TSField -> TSField -> Ordering)
-> (TSField -> TSField -> Bool)
-> (TSField -> TSField -> Bool)
-> (TSField -> TSField -> Bool)
-> (TSField -> TSField -> Bool)
-> (TSField -> TSField -> TSField)
-> (TSField -> TSField -> TSField)
-> Ord TSField
TSField -> TSField -> Bool
TSField -> TSField -> Ordering
TSField -> TSField -> TSField
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TSField -> TSField -> Ordering
compare :: TSField -> TSField -> Ordering
$c< :: TSField -> TSField -> Bool
< :: TSField -> TSField -> Bool
$c<= :: TSField -> TSField -> Bool
<= :: TSField -> TSField -> Bool
$c> :: TSField -> TSField -> Bool
> :: TSField -> TSField -> Bool
$c>= :: TSField -> TSField -> Bool
>= :: TSField -> TSField -> Bool
$cmax :: TSField -> TSField -> TSField
max :: TSField -> TSField -> TSField
$cmin :: TSField -> TSField -> TSField
min :: TSField -> TSField -> TSField
Ord, Int -> TSField -> ShowS
[TSField] -> ShowS
TSField -> String
(Int -> TSField -> ShowS)
-> (TSField -> String) -> ([TSField] -> ShowS) -> Show TSField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TSField -> ShowS
showsPrec :: Int -> TSField -> ShowS
$cshow :: TSField -> String
show :: TSField -> String
$cshowList :: [TSField] -> ShowS
showList :: [TSField] -> ShowS
Show)

-- | Helper for printing fields
type FieldSpec :: Type
data FieldSpec = FieldSpec
  { FieldSpec -> FieldType
fs_type      :: !FieldType
  , FieldSpec -> String
fs_wrapped   :: !String
  , FieldSpec -> String
fs_unwrapped :: !String
  }
  deriving stock (FieldSpec -> FieldSpec -> Bool
(FieldSpec -> FieldSpec -> Bool)
-> (FieldSpec -> FieldSpec -> Bool) -> Eq FieldSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldSpec -> FieldSpec -> Bool
== :: FieldSpec -> FieldSpec -> Bool
$c/= :: FieldSpec -> FieldSpec -> Bool
/= :: FieldSpec -> FieldSpec -> Bool
Eq, Eq FieldSpec
Eq FieldSpec
-> (FieldSpec -> FieldSpec -> Ordering)
-> (FieldSpec -> FieldSpec -> Bool)
-> (FieldSpec -> FieldSpec -> Bool)
-> (FieldSpec -> FieldSpec -> Bool)
-> (FieldSpec -> FieldSpec -> Bool)
-> (FieldSpec -> FieldSpec -> FieldSpec)
-> (FieldSpec -> FieldSpec -> FieldSpec)
-> Ord FieldSpec
FieldSpec -> FieldSpec -> Bool
FieldSpec -> FieldSpec -> Ordering
FieldSpec -> FieldSpec -> FieldSpec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FieldSpec -> FieldSpec -> Ordering
compare :: FieldSpec -> FieldSpec -> Ordering
$c< :: FieldSpec -> FieldSpec -> Bool
< :: FieldSpec -> FieldSpec -> Bool
$c<= :: FieldSpec -> FieldSpec -> Bool
<= :: FieldSpec -> FieldSpec -> Bool
$c> :: FieldSpec -> FieldSpec -> Bool
> :: FieldSpec -> FieldSpec -> Bool
$c>= :: FieldSpec -> FieldSpec -> Bool
>= :: FieldSpec -> FieldSpec -> Bool
$cmax :: FieldSpec -> FieldSpec -> FieldSpec
max :: FieldSpec -> FieldSpec -> FieldSpec
$cmin :: FieldSpec -> FieldSpec -> FieldSpec
min :: FieldSpec -> FieldSpec -> FieldSpec
Ord, Int -> FieldSpec -> ShowS
[FieldSpec] -> ShowS
FieldSpec -> String
(Int -> FieldSpec -> ShowS)
-> (FieldSpec -> String)
-> ([FieldSpec] -> ShowS)
-> Show FieldSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldSpec -> ShowS
showsPrec :: Int -> FieldSpec -> ShowS
$cshow :: FieldSpec -> String
show :: FieldSpec -> String
$cshowList :: [FieldSpec] -> ShowS
showList :: [FieldSpec] -> ShowS
Show)

-- | Construct a FieldSpec assuming standard use and a concrete type variable
concretely :: String -> FieldSpec
concretely :: String -> FieldSpec
concretely String
x = FieldType -> String -> String -> FieldSpec
FieldSpec FieldType
ConcreteField String
x String
x

-- | Construct a FieldSpec assuming standard use and a generic type variable
genericly :: String -> FieldSpec
genericly :: String -> FieldSpec
genericly String
x = FieldType -> String -> String -> FieldSpec
FieldSpec FieldType
GenericField String
x String
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 :: Proxy [a] -> FieldSpec
fieldTypeName Proxy [a]
_ = let
      FieldSpec FieldType
t String
wrapped String
unwrapped = Proxy a -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (Proxy a -> FieldSpec) -> Proxy a -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
    in FieldType -> String -> String -> FieldSpec
FieldSpec FieldType
t (String
"Array<" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
wrapped String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">") String
unwrapped

-- | Handle wrapped payload
instance FieldTypeName a => FieldTypeName (Rec0 a) where
  fieldTypeName :: Proxy (Rec0 a) -> FieldSpec
fieldTypeName Proxy (Rec0 a)
_ = Proxy a -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (Proxy a -> FieldSpec) -> Proxy a -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a

-- | This needs to overlap so it doesn't get treated as an Array
instance {-# OVERLAPS #-} FieldTypeName String where
  fieldTypeName :: Proxy String -> FieldSpec
fieldTypeName Proxy String
_ = String -> FieldSpec
concretely String
"string"

instance FieldTypeName UTCTime where
  fieldTypeName :: Proxy UTCTime -> FieldSpec
fieldTypeName Proxy UTCTime
_ = String -> FieldSpec
concretely String
"string"

instance FieldTypeName T.Text where
  fieldTypeName :: Proxy Text -> FieldSpec
fieldTypeName Proxy Text
_ = String -> FieldSpec
concretely String
"string"

instance (FieldTypeName a, FieldTypeName b) =>  FieldTypeName (Either a b) where
  fieldTypeName :: Proxy (Either a b) -> FieldSpec
fieldTypeName Proxy (Either a b)
_ =
    let a :: FieldSpec
a = Proxy a -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
        b :: FieldSpec
b = Proxy b -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)
        eType :: p -> p -> dst
eType p
l p
r = [i|{ Left: #{l} } | { Right: #{r} }|]
    in FieldType -> String -> String -> FieldSpec
FieldSpec (FieldSpec -> FieldType
fs_type FieldSpec
a FieldType -> FieldType -> FieldType
forall a. Semigroup a => a -> a -> a
<> FieldSpec -> FieldType
fs_type FieldSpec
b) (FieldSpec -> String
fs_wrapped FieldSpec
a String -> ShowS
forall {dst} {p} {p}.
(Interpolatable (IsCustomSink dst) p dst,
 Interpolatable (IsCustomSink dst) p dst) =>
p -> p -> dst
`eType` FieldSpec -> String
fs_wrapped FieldSpec
b) (FieldSpec -> String
fs_unwrapped FieldSpec
a String -> ShowS
forall {dst} {p} {p}.
(Interpolatable (IsCustomSink dst) p dst,
 Interpolatable (IsCustomSink dst) p dst) =>
p -> p -> dst
`eType` FieldSpec -> String
fs_unwrapped FieldSpec
b)

instance (FieldTypeName a, FieldTypeName b) => FieldTypeName (Map a b) where
  fieldTypeName :: Proxy (Map a b) -> FieldSpec
fieldTypeName Proxy (Map a b)
_ = FieldType -> String -> String -> FieldSpec
FieldSpec (FieldSpec -> FieldType
fs_type FieldSpec
a FieldType -> FieldType -> FieldType
forall a. Semigroup a => a -> a -> a
<> FieldSpec -> FieldType
fs_type FieldSpec
b) String
asMap (String -> FieldSpec) -> String -> FieldSpec
forall a b. (a -> b) -> a -> b
$ FieldSpec -> String
fs_unwrapped FieldSpec
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"," String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FieldSpec -> String
fs_unwrapped FieldSpec
b
    where
      a :: FieldSpec
a = Proxy a -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (Proxy a -> FieldSpec) -> Proxy a -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
      b :: FieldSpec
b = Proxy b -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (Proxy b -> FieldSpec) -> Proxy b -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b
      wrappedB :: String
wrappedB = FieldSpec -> String
fs_wrapped FieldSpec
b
      asMap :: String
asMap = [i|{ [key: string]: #{wrappedB} }|]

instance FieldTypeName Int where fieldTypeName :: Proxy Int -> FieldSpec
fieldTypeName Proxy Int
_ = String -> FieldSpec
concretely String
"number"
instance FieldTypeName Integer where fieldTypeName :: Proxy Integer -> FieldSpec
fieldTypeName Proxy Integer
_ = String -> FieldSpec
concretely String
"number"
instance FieldTypeName Float where fieldTypeName :: Proxy Float -> FieldSpec
fieldTypeName Proxy Float
_ = String -> FieldSpec
concretely String
"number"
instance FieldTypeName Bool where fieldTypeName :: Proxy Bool -> FieldSpec
fieldTypeName Proxy Bool
_ = String -> FieldSpec
concretely String
"boolean"
instance FieldTypeName a => FieldTypeName (Maybe a) where
  fieldTypeName :: Proxy (Maybe a) -> FieldSpec
fieldTypeName Proxy (Maybe a)
_ = FieldSpec
inner { $sel:fs_wrapped:FieldSpec :: String
fs_wrapped = FieldSpec -> String
fs_wrapped FieldSpec
inner String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" | null" }
    where inner :: FieldSpec
inner = Proxy a -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

instance FieldTypeName () where
  fieldTypeName :: Proxy () -> FieldSpec
fieldTypeName Proxy ()
_ = String -> FieldSpec
concretely String
"[]"

instance {-# OVERLAPPABLE #-} TypeScriptDefinition a => FieldTypeName a where
  fieldTypeName :: Proxy a -> FieldSpec
fieldTypeName Proxy a
_ = let x :: TSType
x = forall a. TypeScriptDefinition a => TSType
gen @a in TSType -> String -> FieldSpec
ly TSType
x (String -> FieldSpec) -> String -> FieldSpec
forall a b. (a -> b) -> a -> b
$ TSType -> String
tst_constructor TSType
x where
    ly :: TSType -> String -> FieldSpec
ly TSType {String
NonEmpty TSInterface
IsNewtype
$sel:tst_constructor:TSType :: TSType -> String
$sel:tst_doc:TSType :: TSType -> String
$sel:tst_interfaces:TSType :: TSType -> NonEmpty TSInterface
$sel:tst_newtype:TSType :: TSType -> IsNewtype
tst_constructor :: String
tst_doc :: String
tst_interfaces :: NonEmpty TSInterface
tst_newtype :: IsNewtype
..} = if (TSField -> Bool) -> [TSField] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((FieldType -> FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== FieldType
GenericField) (FieldType -> Bool) -> (TSField -> FieldType) -> TSField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldSpec -> FieldType
fs_type (FieldSpec -> FieldType)
-> (TSField -> FieldSpec) -> TSField -> FieldType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSField -> FieldSpec
fieldType) ([TSField] -> Bool)
-> (NonEmpty [TSField] -> [TSField]) -> NonEmpty [TSField] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TSField]] -> [TSField]
forall a. Monoid a => [a] -> a
mconcat ([[TSField]] -> [TSField])
-> (NonEmpty [TSField] -> [[TSField]])
-> NonEmpty [TSField]
-> [TSField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [TSField] -> [[TSField]]
forall a. NonEmpty a -> [a]
toList (NonEmpty [TSField] -> Bool) -> NonEmpty [TSField] -> Bool
forall a b. (a -> b) -> a -> b
$ TSInterface -> [TSField]
tsi_members (TSInterface -> [TSField])
-> NonEmpty TSInterface -> NonEmpty [TSField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TSInterface
tst_interfaces
                     then String -> FieldSpec
genericly else String -> FieldSpec
concretely

instance KnownSymbol s => FieldTypeName (TSGenericVar s) where
  fieldTypeName :: Proxy (TSGenericVar s) -> FieldSpec
fieldTypeName Proxy (TSGenericVar s)
_ = String -> FieldSpec
genericly (String -> FieldSpec)
-> (Proxy s -> String) -> Proxy s -> FieldSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
cap ShowS -> (Proxy s -> String) -> Proxy s -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> FieldSpec) -> Proxy s -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s
    where cap :: ShowS
cap (Char
x:String
xs) = Char -> Char
toUpper Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
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 = Proxy (Rep a) -> GTypeScriptTail (Rep a)
forall a (a :: a). GTypeScriptDef a => Proxy a -> GTypeScriptTail a
ggen (Proxy (Rep a) -> GTypeScriptTail (Rep a))
-> Proxy (Rep a) -> GTypeScriptTail (Rep a)
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
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 :: TSType
gen = String -> TSType
forall a. HasCallStack => String -> a
error String
"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 :: Proxy (D1 ('MetaData name module' package isNew) u)
-> GTypeScriptTail (D1 ('MetaData name module' package isNew) u)
ggen Proxy (D1 ('MetaData name module' package isNew) u)
_ = String -> String -> NonEmpty TSInterface -> IsNewtype -> TSType
TSType
    (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name))
    (String
"Defined in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proxy module' -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @module') String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proxy package -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @package))
    (Proxy u -> GTypeScriptTail u
forall a (a :: a). GTypeScriptDef a => Proxy a -> GTypeScriptTail a
ggen (forall {k} (t :: k). Proxy t
forall (t :: k -> *). Proxy t
Proxy @u))
    (if Proxy isNew -> Degraded isNew
forall k (w :: k). Degrade w => Proxy w -> Degraded w
degrade (forall (t :: Bool). Proxy t
forall {k} (t :: k). Proxy t
Proxy @isNew) then IsNewtype
Newtype else IsNewtype
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 :: Proxy (C1 ('MetaCons name fixity hasNames) u)
-> GTypeScriptTail (C1 ('MetaCons name fixity hasNames) u)
ggen Proxy (C1 ('MetaCons name fixity hasNames) u)
_ = TSInterface -> NonEmpty TSInterface
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TSInterface -> NonEmpty TSInterface)
-> TSInterface -> NonEmpty TSInterface
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> [TSField] -> TSInterface
TSInterface (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)) Maybe String
forall a. Maybe a
Nothing ([TSField] -> [TSField]
checkTSFields ([TSField] -> [TSField]) -> [TSField] -> [TSField]
forall a b. (a -> b) -> a -> b
$ Proxy u -> GTypeScriptTail u
forall a (a :: a). GTypeScriptDef a => Proxy a -> GTypeScriptTail a
ggen (Proxy u -> GTypeScriptTail u) -> Proxy u -> GTypeScriptTail u
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: k -> *). Proxy t
Proxy @u)
    where
    -- Sanity checker @TSField@, this is useful to ensure invariants assumed by JavaScript objects
    checkTSFields :: [TSField] -> [TSField]
checkTSFields [TSField]
ts = let
        uniqueFieldNames :: [Maybe String]
uniqueFieldNames = [Maybe String] -> [Maybe String]
forall a. Ord a => [a] -> [a]
nubOrd ([Maybe String] -> [Maybe String])
-> [Maybe String] -> [Maybe String]
forall a b. (a -> b) -> a -> b
$ TSField -> Maybe String
fieldName (TSField -> Maybe String) -> [TSField] -> [Maybe String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TSField]
ts
      in if [Maybe String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe String]
uniqueFieldNames Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [TSField] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TSField]
ts
         Bool -> Bool -> Bool
&& Bool -> Bool
not ((TSField -> Bool) -> [TSField] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe String -> Bool)
-> (TSField -> Maybe String) -> TSField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSField -> Maybe String
fieldName) [TSField]
ts)
      then String -> [TSField]
forall a. HasCallStack => String -> a
error (String -> [TSField]) -> String -> [TSField]
forall a b. (a -> b) -> a -> b
$ String
"record field names are not unique : " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TSField] -> String
forall a. Show a => a -> String
show [TSField]
ts
      else [TSField]
ts

instance GTypeScriptDef U1 where
  type GTypeScriptTail U1 = [TSField]
  ggen :: Proxy U1 -> GTypeScriptTail U1
ggen Proxy U1
_ = []

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 :: Proxy (S1 ('MetaSel w x y z) u)
-> GTypeScriptTail (S1 ('MetaSel w x y z) u)
ggen Proxy (S1 ('MetaSel w x y z) u)
_ = TSField -> [TSField]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TSField -> [TSField]) -> TSField -> [TSField]
forall a b. (a -> b) -> a -> b
$ TSField
    { $sel:fieldName:TSField :: Maybe String
fieldName = Proxy w -> Degraded w
forall k (w :: k). Degrade w => Proxy w -> Degraded w
degrade (Proxy w -> Degraded w) -> Proxy w -> Degraded w
forall a b. (a -> b) -> a -> b
$ forall (t :: Maybe Symbol). Proxy t
forall {k} (t :: k). Proxy t
Proxy @w
    , $sel:fieldType:TSField :: FieldSpec
fieldType = Proxy u -> FieldSpec
forall a (a :: a). FieldTypeName a => Proxy a -> FieldSpec
fieldTypeName (Proxy u -> FieldSpec) -> Proxy u -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: k -> *). Proxy t
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 :: Proxy (x :+: y) -> GTypeScriptTail (x :+: y)
ggen Proxy (x :+: y)
_ = Proxy x -> GTypeScriptTail x
forall a (a :: a). GTypeScriptDef a => Proxy a -> GTypeScriptTail a
ggen (forall {k} (t :: k). Proxy t
forall (t :: k -> *). Proxy t
Proxy @x) GTypeScriptTail (x :+: y)
-> GTypeScriptTail (x :+: y) -> GTypeScriptTail (x :+: y)
forall a. Semigroup a => a -> a -> a
<> Proxy y -> GTypeScriptTail y
forall a (a :: a). GTypeScriptDef a => Proxy a -> GTypeScriptTail a
ggen (forall {k} (t :: k). Proxy t
forall (t :: k -> *). Proxy t
Proxy @y)

instance
  ( GTypeScriptTail a ~ [TSField]
  , GTypeScriptTail b ~ [TSField]
  , GTypeScriptDef a, GTypeScriptDef b
  ) => GTypeScriptDef (a :*: b) where
  type GTypeScriptTail (a :*: b) = [TSField]
  ggen :: Proxy (a :*: b) -> GTypeScriptTail (a :*: b)
ggen Proxy (a :*: b)
_ = Proxy a -> GTypeScriptTail a
forall a (a :: a). GTypeScriptDef a => Proxy a -> GTypeScriptTail a
ggen (forall {k} (t :: k). Proxy t
forall (t :: k -> *). Proxy t
Proxy @a) GTypeScriptTail (a :*: b)
-> GTypeScriptTail (a :*: b) -> GTypeScriptTail (a :*: b)
forall a. Semigroup a => a -> a -> a
<> Proxy b -> GTypeScriptTail b
forall a (a :: a). GTypeScriptDef a => Proxy a -> GTypeScriptTail a
ggen (forall {k} (t :: k). Proxy t
forall (t :: k -> *). Proxy t
Proxy @b)

printTS :: TSType -> String
printTS :: TSType -> String
printTS TSType{String
NonEmpty TSInterface
IsNewtype
$sel:tst_constructor:TSType :: TSType -> String
$sel:tst_doc:TSType :: TSType -> String
$sel:tst_interfaces:TSType :: TSType -> NonEmpty TSInterface
$sel:tst_newtype:TSType :: TSType -> IsNewtype
tst_constructor :: String
tst_doc :: String
tst_interfaces :: NonEmpty TSInterface
tst_newtype :: IsNewtype
..} =
    [i|// #{tst_doc}
#{typeDecl}|] String -> ShowS
forall a. Semigroup a => a -> a -> a
<> if Bool
isEnum Bool -> Bool -> Bool
|| Bool
isPureProduct then String
"" else
      (if Bool
isSingleRecord then ShowS
forall a. a -> a
id else String -> ShowS
forall a. Monoid a => a -> a -> a
mappend String
"\n") String
interfaces
    where
      -- All the type variables found
      vars :: [TSField]
      vars :: [TSField]
vars = [[TSField]] -> [TSField]
forall a. Monoid a => [a] -> a
mconcat ([[TSField]] -> [TSField])
-> (NonEmpty [TSField] -> [[TSField]])
-> NonEmpty [TSField]
-> [TSField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [TSField] -> [[TSField]]
forall a. NonEmpty a -> [a]
toList (NonEmpty [TSField] -> [TSField])
-> NonEmpty [TSField] -> [TSField]
forall a b. (a -> b) -> a -> b
$ TSInterface -> [TSField]
tsi_members (TSInterface -> [TSField])
-> NonEmpty TSInterface -> NonEmpty [TSField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TSInterface
tst_interfaces

      -- The generic variables in TypeScript syntax IE <A,B>
      -- These must be unique
      generics :: String
      generics :: String
generics = [TSField] -> String
mkGenericVars ([TSField] -> String) -> [TSField] -> String
forall a b. (a -> b) -> a -> b
$ [TSField] -> [TSField]
forall a. Ord a => [a] -> [a]
nubOrd [TSField]
vars

      -- The constructors of the original haskell data type as our AST
      constructors :: [(String, [TSField])]
      constructors :: [(String, [TSField])]
constructors = NonEmpty (String, [TSField]) -> [(String, [TSField])]
forall a. NonEmpty a -> [a]
toList (NonEmpty (String, [TSField]) -> [(String, [TSField])])
-> NonEmpty (String, [TSField]) -> [(String, [TSField])]
forall a b. (a -> b) -> a -> b
$ (\TSInterface
x -> (TSInterface -> String
tsi_constructor TSInterface
x,TSInterface -> [TSField]
tsi_members TSInterface
x)) (TSInterface -> (String, [TSField]))
-> NonEmpty TSInterface -> NonEmpty (String, [TSField])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TSInterface
tst_interfaces

      -- The interfaces associated with the constructors in TypeScript syntax
      interfaces :: String
      interfaces :: String
interfaces = if NonEmpty TSInterface -> Bool
forall a. NonEmpty a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null NonEmpty TSInterface
tst_interfaces then String
"" else
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> (NonEmpty String -> [String]) -> NonEmpty String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
toList (NonEmpty String -> String) -> NonEmpty String -> String
forall a b. (a -> b) -> a -> b
$ TSInterface -> String
printTSInterface (TSInterface -> String)
-> (TSInterface -> TSInterface) -> TSInterface -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSInterface -> TSInterface
hackInTypeName (TSInterface -> String) -> NonEmpty TSInterface -> NonEmpty String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TSInterface
tst_interfaces

      -- Is this going to be a special variant for Aeson?
      isUnit, isSingleRecord, isPureProduct, isEnum :: Bool
      isUnit :: Bool
isUnit = [(String, [TSField])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, [TSField])]
constructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Bool
isEnum
      isSingleRecord :: Bool
isSingleRecord = [(String, [TSField])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, [TSField])]
constructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& (TSInterface -> Bool) -> NonEmpty TSInterface -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((TSField -> Bool) -> [TSField] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> (TSField -> Maybe String) -> TSField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSField -> Maybe String
fieldName) ([TSField] -> Bool)
-> (TSInterface -> [TSField]) -> TSInterface -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSInterface -> [TSField]
tsi_members) NonEmpty TSInterface
tst_interfaces
      isPureProduct :: Bool
isPureProduct = [(String, [TSField])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, [TSField])]
constructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        Bool -> Bool -> Bool
&& (TSInterface -> Bool) -> NonEmpty TSInterface -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((TSField -> Bool) -> [TSField] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe String -> Bool)
-> (TSField -> Maybe String) -> TSField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSField -> Maybe String
fieldName) ([TSField] -> Bool)
-> (TSInterface -> [TSField]) -> TSInterface -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSInterface -> [TSField]
tsi_members) NonEmpty TSInterface
tst_interfaces
      isEnum :: Bool
isEnum = (TSInterface -> Bool) -> NonEmpty TSInterface -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\TSInterface{String
[TSField]
Maybe String
$sel:tsi_constructor:TSInterface :: TSInterface -> String
$sel:tsi_typeName:TSInterface :: TSInterface -> Maybe String
$sel:tsi_members:TSInterface :: TSInterface -> [TSField]
tsi_constructor :: String
tsi_typeName :: Maybe String
tsi_members :: [TSField]
..} -> [TSField] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TSField]
tsi_members) NonEmpty TSInterface
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 :: TSInterface -> TSInterface
hackInTypeName TSInterface
face = if Bool
isSingleRecord then TSInterface
face { $sel:tsi_typeName:TSInterface :: Maybe String
tsi_typeName = String -> Maybe String
forall a. a -> Maybe a
Just String
tst_constructor } else TSInterface
face

      -- The declaration of the type, if not a single record (which is just the inner interface)
      typeDecl :: String
      typeDecl :: String
typeDecl = if Bool
isSingleRecord Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isUnit then String
"" :: String else
        [i|type #{tst_constructor}#{generics} = #{transObj};|] where
          transObj :: String
transObj
            -- Aeson says so
            | Bool
isUnit = String
"[]"
            -- Its a newtype
            | IsNewtype
tst_newtype IsNewtype -> IsNewtype -> Bool
forall a. Eq a => a -> a -> Bool
== IsNewtype
Newtype = case [TSField]
vars of
                              [TSField {Maybe String
FieldSpec
$sel:fieldName:TSField :: TSField -> Maybe String
$sel:fieldType:TSField :: TSField -> FieldSpec
fieldName :: Maybe String
fieldType :: FieldSpec
..}] -> FieldSpec -> String
fs_wrapped FieldSpec
fieldType
                              [TSField]
_ -> ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"newtype wrong number of fields: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TSField] -> String
forall a. Show a => a -> String
show [TSField]
vars
            -- This is a data type with mulitple fields and only one constructor, and so is a big tuple
            | Bool
isPureProduct = String
"[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((\TSField {Maybe String
FieldSpec
$sel:fieldName:TSField :: TSField -> Maybe String
$sel:fieldType:TSField :: TSField -> FieldSpec
fieldName :: Maybe String
fieldType :: FieldSpec
..} -> FieldSpec -> String
fs_wrapped FieldSpec
fieldType) (TSField -> String) -> [TSField] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TSField]
vars) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"
            -- Its a union type
            | Bool
otherwise = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" | "
                  ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (if Bool
isEnum then (\String
x ->  String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"") else ShowS
forall a. a -> a
id)
                  ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (\(String
c,[TSField]
ms) -> String
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TSField] -> String
mkGenericVars [TSField]
ms) ((String, [TSField]) -> String)
-> [(String, [TSField])] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, [TSField])]
constructors

printTSInterface :: TSInterface -> String
printTSInterface :: TSInterface -> String
printTSInterface TSInterface{String
[TSField]
Maybe String
$sel:tsi_constructor:TSInterface :: TSInterface -> String
$sel:tsi_typeName:TSInterface :: TSInterface -> Maybe String
$sel:tsi_members:TSInterface :: TSInterface -> [TSField]
tsi_constructor :: String
tsi_typeName :: Maybe String
tsi_members :: [TSField]
..} = [i|interface #{typeName}#{generics} {
  #{tag}readonly tag: "#{tsi_constructor}";|]
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
contents then String
"" else String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
contents)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\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 :: String
typeName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
tsi_constructor Maybe String
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 :: String
tag = if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
tsi_typeName then String
"// " else String
""

     -- Make list of variables for contents
     unnamed :: String
     unnamed :: String
unnamed = (String -> ShowS) -> String -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ShowS
forall a. Monoid a => a -> a -> a
mappend String
";" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
       if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ms Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
"[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]" else [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String]
ms
       where ms :: [String]
ms = FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (TSField -> FieldSpec) -> TSField -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSField -> FieldSpec
fieldType (TSField -> String) -> [TSField] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TSField]
tsi_members

     -- Payload of the interface
     contents :: String
     contents :: String
contents = if Bool
isRecord then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ TSField -> String
namedField (TSField -> String) -> [TSField] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TSField]
tsi_members
                            else String
"  readonly contents: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
unnamed

     -- Do all fields have names?
     isRecord :: Bool
     isRecord :: Bool
isRecord = (TSField -> Bool) -> [TSField] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> (TSField -> Maybe String) -> TSField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSField -> Maybe String
fieldName) [TSField]
tsi_members

     -- Build one named field
     namedField :: TSField -> String
     namedField :: TSField -> String
namedField TSField {Maybe String
FieldSpec
$sel:fieldName:TSField :: TSField -> Maybe String
$sel:fieldType:TSField :: TSField -> FieldSpec
fieldName :: Maybe String
fieldType :: FieldSpec
..} = String
"  readonly " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fieldName' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fieldType' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
";"
       where fieldName' :: String
fieldName' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error String
"field name was not found") Maybe String
fieldName
             fieldType' :: String
fieldType' = FieldSpec -> String
fs_wrapped FieldSpec
fieldType

     -- Generics of the system
     generics :: String
     generics :: String
generics = [TSField] -> String
mkGenericVars [TSField]
tsi_members

mkGenericVars :: [TSField] -> String
mkGenericVars :: [TSField] -> String
mkGenericVars [TSField]
xs = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
vars then String
"" else String
"<" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
vars String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">"
  where
  vars :: [String]
vars = (TSField -> Maybe String) -> [TSField] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (FieldSpec -> Maybe String
go (FieldSpec -> Maybe String)
-> (TSField -> FieldSpec) -> TSField -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSField -> FieldSpec
fieldType) [TSField]
xs
  go :: FieldSpec -> Maybe String
go = \case x :: FieldSpec
x@(FieldSpec FieldType
GenericField String
_ String
_) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ FieldSpec -> String
fs_unwrapped FieldSpec
x; FieldSpec
_ -> Maybe String
forall a. Maybe a
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 :: Proxy ('Just s) -> Degraded ('Just s)
degrade Proxy ('Just s)
_ = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> String) -> Proxy s -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s
instance Degrade 'Nothing where
  type Degraded 'Nothing = Maybe String
  degrade :: Proxy 'Nothing -> Degraded 'Nothing
degrade Proxy 'Nothing
_ = Maybe String
Degraded 'Nothing
forall a. Maybe a
Nothing
instance Degrade 'True where
  type Degraded  'True = Bool
  degrade :: Proxy 'True -> Degraded 'True
degrade Proxy 'True
_ =     Bool
Degraded 'True
True
instance Degrade 'False where
  type Degraded  'False = Bool
  degrade :: Proxy 'False -> Degraded 'False
degrade Proxy 'False
_ =     Bool
Degraded 'False
False
instance Degrade 'Newtype where
  type Degraded  'Newtype = IsNewtype
  degrade :: Proxy 'Newtype -> Degraded 'Newtype
degrade Proxy 'Newtype
_ =     Degraded 'Newtype
IsNewtype
Newtype
instance Degrade 'Oldtype where
  type Degraded  'Oldtype = IsNewtype
  degrade :: Proxy 'Oldtype -> Degraded 'Oldtype
degrade Proxy 'Oldtype
_ =     Degraded 'Oldtype
IsNewtype
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 :: forall a. TypeScriptDefinition a => Proxy a -> String
getPrintedDefinition Proxy a
_ = TSType -> String
printTS (TSType -> String) -> TSType -> String
forall a b. (a -> b) -> a -> b
$ forall a. TypeScriptDefinition a => TSType
gen @a

-- This is present as debugging tool
type Foo :: Type -> Type
data Foo a = Foo
           | Bar Int
  deriving stock (Foo a -> Foo a -> Bool
(Foo a -> Foo a -> Bool) -> (Foo a -> Foo a -> Bool) -> Eq (Foo a)
forall a. Foo a -> Foo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Foo a -> Foo a -> Bool
== :: Foo a -> Foo a -> Bool
$c/= :: forall a. Foo a -> Foo a -> Bool
/= :: Foo a -> Foo a -> Bool
Eq, (forall x. Foo a -> Rep (Foo a) x)
-> (forall x. Rep (Foo a) x -> Foo a) -> Generic (Foo a)
forall x. Rep (Foo a) x -> Foo a
forall x. Foo a -> Rep (Foo a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Foo a) x -> Foo a
forall a x. Foo a -> Rep (Foo a) x
$cfrom :: forall a x. Foo a -> Rep (Foo a) x
from :: forall x. Foo a -> Rep (Foo a) x
$cto :: forall a x. Rep (Foo a) x -> Foo a
to :: forall x. Rep (Foo a) x -> Foo a
Generic, Eq (Foo a)
Eq (Foo a)
-> (Foo a -> Foo a -> Ordering)
-> (Foo a -> Foo a -> Bool)
-> (Foo a -> Foo a -> Bool)
-> (Foo a -> Foo a -> Bool)
-> (Foo a -> Foo a -> Bool)
-> (Foo a -> Foo a -> Foo a)
-> (Foo a -> Foo a -> Foo a)
-> Ord (Foo a)
Foo a -> Foo a -> Bool
Foo a -> Foo a -> Ordering
Foo a -> Foo a -> Foo a
forall a. Eq (Foo a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Foo a -> Foo a -> Bool
forall a. Foo a -> Foo a -> Ordering
forall a. Foo a -> Foo a -> Foo a
$ccompare :: forall a. Foo a -> Foo a -> Ordering
compare :: Foo a -> Foo a -> Ordering
$c< :: forall a. Foo a -> Foo a -> Bool
< :: Foo a -> Foo a -> Bool
$c<= :: forall a. Foo a -> Foo a -> Bool
<= :: Foo a -> Foo a -> Bool
$c> :: forall a. Foo a -> Foo a -> Bool
> :: Foo a -> Foo a -> Bool
$c>= :: forall a. Foo a -> Foo a -> Bool
>= :: Foo a -> Foo a -> Bool
$cmax :: forall a. Foo a -> Foo a -> Foo a
max :: Foo a -> Foo a -> Foo a
$cmin :: forall a. Foo a -> Foo a -> Foo a
min :: Foo a -> Foo a -> Foo a
Ord, ReadPrec [Foo a]
ReadPrec (Foo a)
Int -> ReadS (Foo a)
ReadS [Foo a]
(Int -> ReadS (Foo a))
-> ReadS [Foo a]
-> ReadPrec (Foo a)
-> ReadPrec [Foo a]
-> Read (Foo a)
forall a. ReadPrec [Foo a]
forall a. ReadPrec (Foo a)
forall a. Int -> ReadS (Foo a)
forall a. ReadS [Foo a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Int -> ReadS (Foo a)
readsPrec :: Int -> ReadS (Foo a)
$creadList :: forall a. ReadS [Foo a]
readList :: ReadS [Foo a]
$creadPrec :: forall a. ReadPrec (Foo a)
readPrec :: ReadPrec (Foo a)
$creadListPrec :: forall a. ReadPrec [Foo a]
readListPrec :: ReadPrec [Foo a]
Read, Int -> Foo a -> ShowS
[Foo a] -> ShowS
Foo a -> String
(Int -> Foo a -> ShowS)
-> (Foo a -> String) -> ([Foo a] -> ShowS) -> Show (Foo a)
forall a. Int -> Foo a -> ShowS
forall a. [Foo a] -> ShowS
forall a. Foo a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Foo a -> ShowS
showsPrec :: Int -> Foo a -> ShowS
$cshow :: forall a. Foo a -> String
show :: Foo a -> String
$cshowList :: forall a. [Foo a] -> ShowS
showList :: [Foo a] -> ShowS
Show)
  deriving anyclass (TSType
TSType -> TypeScriptDefinition (Foo a)
forall a. TSType
forall a. TSType -> TypeScriptDefinition a
$cgen :: forall a. TSType
gen :: TSType
TypeScriptDefinition)