{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PolyKinds #-}

module Elminator.Generics.Simple where

import Control.Monad.State.Strict
import qualified Data.List as DL
import qualified Data.Map.Strict as DMS
import Data.Proxy
import Data.String
import Data.Kind
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Typeable
import GHC.Generics
import GHC.TypeLits
import Language.Haskell.TH hiding (Type)

newtype CName =
  CName Text
  deriving (Int -> CName -> ShowS
[CName] -> ShowS
CName -> String
(Int -> CName -> ShowS)
-> (CName -> String) -> ([CName] -> ShowS) -> Show CName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CName -> ShowS
showsPrec :: Int -> CName -> ShowS
$cshow :: CName -> String
show :: CName -> String
$cshowList :: [CName] -> ShowS
showList :: [CName] -> ShowS
Show)

data HField =
  HField (Maybe Text) HType
  deriving (Int -> HField -> ShowS
[HField] -> ShowS
HField -> String
(Int -> HField -> ShowS)
-> (HField -> String) -> ([HField] -> ShowS) -> Show HField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HField -> ShowS
showsPrec :: Int -> HField -> ShowS
$cshow :: HField -> String
show :: HField -> String
$cshowList :: [HField] -> ShowS
showList :: [HField] -> ShowS
Show)

type HState = State (DMS.Map MData ())

type ExTypeName = Text

type ExEncoderName = Text

type ExDecoderName = Text

type ModuleName = Text

type SymbolName = Text

type ExItem = (ModuleName, SymbolName)

data ExInfo a =
  ExInfo
    { forall a. ExInfo a -> ExItem
exType :: ExItem
    , forall a. ExInfo a -> Maybe ExItem
exEncoder :: Maybe ExItem
    , forall a. ExInfo a -> Maybe ExItem
exDecoder :: Maybe ExItem
    , forall a. ExInfo a -> [a]
exTypeArgs :: [a]
    }
  deriving (Int -> ExInfo a -> ShowS
[ExInfo a] -> ShowS
ExInfo a -> String
(Int -> ExInfo a -> ShowS)
-> (ExInfo a -> String) -> ([ExInfo a] -> ShowS) -> Show (ExInfo a)
forall a. Show a => Int -> ExInfo a -> ShowS
forall a. Show a => [ExInfo a] -> ShowS
forall a. Show a => ExInfo a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ExInfo a -> ShowS
showsPrec :: Int -> ExInfo a -> ShowS
$cshow :: forall a. Show a => ExInfo a -> String
show :: ExInfo a -> String
$cshowList :: forall a. Show a => [ExInfo a] -> ShowS
showList :: [ExInfo a] -> ShowS
Show)

data MData =
  MData
    { MData -> Text
_mTypeName :: Text
    , MData -> Text
_mModuleName :: Text
    , MData -> Text
_mPackageName :: Text
    }
  deriving (Int -> MData -> ShowS
[MData] -> ShowS
MData -> String
(Int -> MData -> ShowS)
-> (MData -> String) -> ([MData] -> ShowS) -> Show MData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MData -> ShowS
showsPrec :: Int -> MData -> ShowS
$cshow :: MData -> String
show :: MData -> String
$cshowList :: [MData] -> ShowS
showList :: [MData] -> ShowS
Show, Eq MData
Eq MData =>
(MData -> MData -> Ordering)
-> (MData -> MData -> Bool)
-> (MData -> MData -> Bool)
-> (MData -> MData -> Bool)
-> (MData -> MData -> Bool)
-> (MData -> MData -> MData)
-> (MData -> MData -> MData)
-> Ord MData
MData -> MData -> Bool
MData -> MData -> Ordering
MData -> MData -> MData
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 :: MData -> MData -> Ordering
compare :: MData -> MData -> Ordering
$c< :: MData -> MData -> Bool
< :: MData -> MData -> Bool
$c<= :: MData -> MData -> Bool
<= :: MData -> MData -> Bool
$c> :: MData -> MData -> Bool
> :: MData -> MData -> Bool
$c>= :: MData -> MData -> Bool
>= :: MData -> MData -> Bool
$cmax :: MData -> MData -> MData
max :: MData -> MData -> MData
$cmin :: MData -> MData -> MData
min :: MData -> MData -> MData
Ord, MData -> MData -> Bool
(MData -> MData -> Bool) -> (MData -> MData -> Bool) -> Eq MData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MData -> MData -> Bool
== :: MData -> MData -> Bool
$c/= :: MData -> MData -> Bool
/= :: MData -> MData -> Bool
Eq)

instance IsString MData where
  fromString :: String -> MData
fromString String
x = Text -> Text -> Text -> MData
MData (String -> Text
pack String
x) Text
"" Text
""

data HConstructor =
  HConstructor CName [HField]
  deriving (Int -> HConstructor -> ShowS
[HConstructor] -> ShowS
HConstructor -> String
(Int -> HConstructor -> ShowS)
-> (HConstructor -> String)
-> ([HConstructor] -> ShowS)
-> Show HConstructor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HConstructor -> ShowS
showsPrec :: Int -> HConstructor -> ShowS
$cshow :: HConstructor -> String
show :: HConstructor -> String
$cshowList :: [HConstructor] -> ShowS
showList :: [HConstructor] -> ShowS
Show)

data TypeVar
  = Used Name
  | Phantom Name
  deriving (TypeVar -> TypeVar -> Bool
(TypeVar -> TypeVar -> Bool)
-> (TypeVar -> TypeVar -> Bool) -> Eq TypeVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeVar -> TypeVar -> Bool
== :: TypeVar -> TypeVar -> Bool
$c/= :: TypeVar -> TypeVar -> Bool
/= :: TypeVar -> TypeVar -> Bool
Eq, Int -> TypeVar -> ShowS
[TypeVar] -> ShowS
TypeVar -> String
(Int -> TypeVar -> ShowS)
-> (TypeVar -> String) -> ([TypeVar] -> ShowS) -> Show TypeVar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeVar -> ShowS
showsPrec :: Int -> TypeVar -> ShowS
$cshow :: TypeVar -> String
show :: TypeVar -> String
$cshowList :: [TypeVar] -> ShowS
showList :: [TypeVar] -> ShowS
Show)

data UDefData =
  UDefData
    { UDefData -> MData
udefdMdata :: MData
    , UDefData -> [HType]
udefdTypeArgs :: [HType]
    , UDefData -> [HConstructor]
udefDConstructors :: [HConstructor]
    }
  deriving (Int -> UDefData -> ShowS
[UDefData] -> ShowS
UDefData -> String
(Int -> UDefData -> ShowS)
-> (UDefData -> String) -> ([UDefData] -> ShowS) -> Show UDefData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UDefData -> ShowS
showsPrec :: Int -> UDefData -> ShowS
$cshow :: UDefData -> String
show :: UDefData -> String
$cshowList :: [UDefData] -> ShowS
showList :: [UDefData] -> ShowS
Show)

-- | This type holds the type information we get from generics.
-- Only the `HExternal` constructor is supposed to be used by the programmer
-- to implement `ToHType` instances for entites that are predefined in Elm. A sample can be seen below.
--
-- Here, let `MyExtType a b` be a type which has the corresponding type, encoders and decoders predefined in Elm
-- in a module named "Lib". Here is how you can implement a ToHType instance for this type so that your other
-- autogenerated types can have fields of type `MyExtType a b`.
--
-- @
--
-- instance (ToHType a, ToHType b) => ToHType (MyExtType a b) where
--   toHType _ = do
--     ha <- toHType (Proxy :: Proxy a)
--     hb <- toHType (Proxy :: Proxy b)
--     pure $
--       HExternal
--         (ExInfo
--            ("External", "MyExtType")
--            (Just ("External", "encodeMyExtType"))
--            (Just ("External", "decodeMyExtType"))
--            [ha, hb])
--
-- @
--
data HType
  = HUDef UDefData
  | HMaybe HType
  | HList HType
  | HPrimitive MData
  | HRecursive MData
  | HExternal (ExInfo HType)
  deriving (Int -> HType -> ShowS
[HType] -> ShowS
HType -> String
(Int -> HType -> ShowS)
-> (HType -> String) -> ([HType] -> ShowS) -> Show HType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HType -> ShowS
showsPrec :: Int -> HType -> ShowS
$cshow :: HType -> String
show :: HType -> String
$cshowList :: [HType] -> ShowS
showList :: [HType] -> ShowS
Show)

class ToHType_ (f :: Type -> Type) where
  toHType_ :: Proxy f -> HState HType

class ToHField_ (f :: Type -> Type) where
  toHField_ :: Proxy f -> HState [HField]

class ToHConstructor_ (f :: Type -> Type) where
  toHConstructor_ :: Proxy f -> HState [HConstructor]

type family ExtractTArgs (f :: k) :: [Type] where
  ExtractTArgs ((b :: Type -> k) a) = a : ExtractTArgs b
  ExtractTArgs f = '[]

class ToHTArgs f where
  toHTArgs :: Proxy f -> [HState HType]

instance ToHTArgs '[] where
  toHTArgs :: Proxy '[] -> [HState HType]
toHTArgs Proxy '[]
_ = []

instance (ToHType a, ToHTArgs x) => ToHTArgs (a : x) where
  toHTArgs :: Proxy (a : x) -> [HState HType]
toHTArgs Proxy (a : x)
_ = Proxy a -> HState HType
forall f. ToHType f => Proxy f -> HState HType
toHType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) HState HType -> [HState HType] -> [HState HType]
forall a. a -> [a] -> [a]
: Proxy x -> [HState HType]
forall {k} (f :: k). ToHTArgs f => Proxy f -> [HState HType]
toHTArgs (Proxy x
forall {k} (t :: k). Proxy t
Proxy :: Proxy x)

class ToHType f where
  toHType :: Proxy f -> HState HType
  default toHType :: (ToHTArgs (ExtractTArgs f), Generic f, ToHType_ (Rep f)) =>
    Proxy f -> HState HType
  toHType Proxy f
_ = do
    [HType]
targs <- [HState HType] -> StateT (Map MData ()) Identity [HType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (Proxy (ExtractTArgs f) -> [HState HType]
forall {k} (f :: k). ToHTArgs f => Proxy f -> [HState HType]
toHTArgs (Proxy (ExtractTArgs f)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (ExtractTArgs f)))
    HType
htype <- Proxy (Rep f) -> HState HType
forall (f :: * -> *). ToHType_ f => Proxy f -> HState HType
toHType_ (Proxy (Rep f)
forall {k} (t :: k). Proxy t
Proxy :: (Proxy (Rep f)))
    HType -> HState HType
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HType -> HState HType) -> HType -> HState HType
forall a b. (a -> b) -> a -> b
$
      case HType
htype of
        HUDef UDefData
ud -> UDefData -> HType
HUDef (UDefData -> HType) -> UDefData -> HType
forall a b. (a -> b) -> a -> b
$ UDefData
ud {udefdTypeArgs = DL.reverse targs}
        HType
a -> HType
a

instance (ToHConstructor_ b, KnownSymbol a1, KnownSymbol a2, KnownSymbol a3) =>
         ToHType_ (D1 ('MetaData a1 a2 a3 a4) b) where
  toHType_ :: Proxy (D1 ('MetaData a1 a2 a3 a4) b) -> HState HType
toHType_ Proxy (D1 ('MetaData a1 a2 a3 a4) b)
_ =
    let mdata :: MData
mdata =
          Text -> Text -> Text -> MData
MData
            (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a1 -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy a1
forall {k} (t :: k). Proxy t
Proxy :: Proxy a1))
            (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a2 -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy a2
forall {k} (t :: k). Proxy t
Proxy :: Proxy a2))
            (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a3 -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy a3
forall {k} (t :: k). Proxy t
Proxy :: Proxy a3))
     in do Map MData ()
seen <- StateT (Map MData ()) Identity (Map MData ())
forall s (m :: * -> *). MonadState s m => m s
get
           case MData -> Map MData () -> Maybe ()
forall k a. Ord k => k -> Map k a -> Maybe a
DMS.lookup MData
mdata Map MData ()
seen of
             Just ()
_ -> HType -> HState HType
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HType -> HState HType) -> HType -> HState HType
forall a b. (a -> b) -> a -> b
$ MData -> HType
HRecursive MData
mdata
             Maybe ()
Nothing -> do
               case Text -> Maybe Int
isTuple (Text -> Maybe Int) -> Text -> Maybe Int
forall a b. (a -> b) -> a -> b
$ MData -> Text
_mTypeName MData
mdata of
                 Just Int
_ -> () -> StateT (Map MData ()) Identity ()
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                 Maybe Int
Nothing -> Map MData () -> StateT (Map MData ()) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Map MData () -> StateT (Map MData ()) Identity ())
-> Map MData () -> StateT (Map MData ()) Identity ()
forall a b. (a -> b) -> a -> b
$ MData -> () -> Map MData () -> Map MData ()
forall k a. Ord k => k -> a -> Map k a -> Map k a
DMS.insert MData
mdata () Map MData ()
seen
               [HConstructor]
cons_ <- Proxy b -> HState [HConstructor]
forall (f :: * -> *).
ToHConstructor_ f =>
Proxy f -> HState [HConstructor]
toHConstructor_ (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
               HType -> HState HType
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HType -> HState HType) -> HType -> HState HType
forall a b. (a -> b) -> a -> b
$ UDefData -> HType
HUDef (UDefData -> HType) -> UDefData -> HType
forall a b. (a -> b) -> a -> b
$ MData -> [HType] -> [HConstructor] -> UDefData
UDefData MData
mdata [] [HConstructor]
cons_

isTuple :: Text -> Maybe Int
isTuple :: Text -> Maybe Int
isTuple Text
t =
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
c, Text
_) ->
      if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'('
        then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
DL.length ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') Text
t
        else Maybe Int
forall a. Maybe a
Nothing
    Maybe (Char, Text)
_ -> Maybe Int
forall a. Maybe a
Nothing

instance ToHConstructor_ V1 where
  toHConstructor_ :: Proxy V1 -> HState [HConstructor]
toHConstructor_ Proxy V1
_ = [HConstructor] -> HState [HConstructor]
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (KnownSymbol cname, ToHField_ s) =>
         ToHConstructor_ (C1 ('MetaCons cname a b) s) where
  toHConstructor_ :: Proxy (C1 ('MetaCons cname a b) s) -> HState [HConstructor]
toHConstructor_ Proxy (C1 ('MetaCons cname a b) s)
_ = do
    [HField]
hfield <- Proxy s -> HState [HField]
forall (f :: * -> *). ToHField_ f => Proxy f -> HState [HField]
toHField_ (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s)
    [HConstructor] -> HState [HConstructor]
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CName -> [HField] -> HConstructor
HConstructor (Text -> CName
CName (Text -> CName) -> Text -> CName
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy cname -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy cname
forall {k} (t :: k). Proxy t
Proxy :: Proxy cname)) [HField]
hfield]

instance ToHField_ U1 where
  toHField_ :: Proxy U1 -> HState [HField]
toHField_ Proxy U1
_ = [HField] -> HState [HField]
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (KnownSymbol cname, ToHType_ w) =>
         ToHField_ (S1 ('MetaSel ('Just cname) a b c) w) where
  toHField_ :: Proxy (S1 ('MetaSel ('Just cname) a b c) w) -> HState [HField]
toHField_ Proxy (S1 ('MetaSel ('Just cname) a b c) w)
_ = do
    HType
htype <- Proxy w -> HState HType
forall (f :: * -> *). ToHType_ f => Proxy f -> HState HType
toHType_ (Proxy w
forall {k} (t :: k). Proxy t
Proxy :: Proxy w)
    [HField] -> HState [HField]
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Text -> HType -> HField
HField (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy cname -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy cname
forall {k} (t :: k). Proxy t
Proxy :: Proxy cname)) HType
htype]

instance (ToHType_ w) => ToHField_ (S1 ('MetaSel 'Nothing a b c) w) where
  toHField_ :: Proxy (S1 ('MetaSel 'Nothing a b c) w) -> HState [HField]
toHField_ Proxy (S1 ('MetaSel 'Nothing a b c) w)
_ = do
    HType
htype <- Proxy w -> HState HType
forall (f :: * -> *). ToHType_ f => Proxy f -> HState HType
toHType_ (Proxy w
forall {k} (t :: k). Proxy t
Proxy :: Proxy w)
    [HField] -> HState [HField]
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Text -> HType -> HField
HField Maybe Text
forall a. Maybe a
Nothing HType
htype]

instance (ToHField_ a, ToHField_ b) => ToHField_ (a :*: b) where
  toHField_ :: Proxy (a :*: b) -> HState [HField]
toHField_ Proxy (a :*: b)
_ = do
    [HField]
hfield1 <- Proxy a -> HState [HField]
forall (f :: * -> *). ToHField_ f => Proxy f -> HState [HField]
toHField_ (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    [HField]
hfield2 <- Proxy b -> HState [HField]
forall (f :: * -> *). ToHField_ f => Proxy f -> HState [HField]
toHField_ (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
    [HField] -> HState [HField]
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HField] -> HState [HField]) -> [HField] -> HState [HField]
forall a b. (a -> b) -> a -> b
$ [HField]
hfield1 [HField] -> [HField] -> [HField]
forall a. [a] -> [a] -> [a]
++ [HField]
hfield2

instance (ToHConstructor_ a, ToHConstructor_ b) =>
         ToHConstructor_ (a :+: b) where
  toHConstructor_ :: Proxy (a :+: b) -> HState [HConstructor]
toHConstructor_ Proxy (a :+: b)
_ = do
    [HConstructor]
lhs <- Proxy a -> HState [HConstructor]
forall (f :: * -> *).
ToHConstructor_ f =>
Proxy f -> HState [HConstructor]
toHConstructor_ (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    [HConstructor]
rhs <- Proxy b -> HState [HConstructor]
forall (f :: * -> *).
ToHConstructor_ f =>
Proxy f -> HState [HConstructor]
toHConstructor_ (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
    [HConstructor] -> HState [HConstructor]
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HConstructor] -> HState [HConstructor])
-> [HConstructor] -> HState [HConstructor]
forall a b. (a -> b) -> a -> b
$ [HConstructor]
lhs [HConstructor] -> [HConstructor] -> [HConstructor]
forall a. [a] -> [a] -> [a]
++ [HConstructor]
rhs

instance (ToHType a) => ToHType_ (K1 R a) where
  toHType_ :: Proxy (K1 R a) -> HState HType
toHType_ Proxy (K1 R a)
_ = Proxy a -> HState HType
forall f. ToHType f => Proxy f -> HState HType
toHType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

instance {-# OVERLAPPABLE #-} (Typeable a) => ToHType a where
  toHType :: Proxy a -> HState HType
toHType Proxy a
p = HType -> HState HType
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HType -> HState HType) -> HType -> HState HType
forall a b. (a -> b) -> a -> b
$ Proxy a -> HType
forall {k} (a :: k). Typeable a => Proxy a -> HType
mkHType Proxy a
p

-- Common types
instance (ToHType a, ToHType b) => ToHType (Either a b)

instance (ToHType a) => ToHType (Maybe a) where
  toHType :: Proxy (Maybe a) -> HState HType
toHType Proxy (Maybe a)
_ = do
    HType
htype <- Proxy a -> HState HType
forall f. ToHType f => Proxy f -> HState HType
toHType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    HType -> HState HType
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HType -> HState HType) -> HType -> HState HType
forall a b. (a -> b) -> a -> b
$ HType -> HType
HMaybe HType
htype

-- We need these tuple instances despite of the general ToHType instance
-- because we need to special case tupless to exclude them from recursion
-- tracking, which is included in the default implementation if ToHType class
instance ToHType ()

instance (ToHType a1, ToHType a2) => ToHType (a1, a2)

instance (ToHType a1, ToHType a2, ToHType a3) => ToHType (a1, a2, a3)

instance (ToHType a1, ToHType a2, ToHType a3, ToHType a4) =>
         ToHType (a1, a2, a3, a4)

instance (ToHType a1, ToHType a2, ToHType a3, ToHType a4, ToHType a5) =>
         ToHType (a1, a2, a3, a4, a5)

instance ( ToHType a1
         , ToHType a2
         , ToHType a3
         , ToHType a4
         , ToHType a5
         , ToHType a6
         ) =>
         ToHType (a1, a2, a3, a4, a5, a6)

instance ( ToHType a1
         , ToHType a2
         , ToHType a3
         , ToHType a4
         , ToHType a5
         , ToHType a6
         , ToHType a7
         ) =>
         ToHType (a1, a2, a3, a4, a5, a6, a7)

instance (ToHType a) => ToHType [a] where
  toHType :: Proxy [a] -> HState HType
toHType Proxy [a]
_ = do
    HType
htype <- Proxy a -> HState HType
forall f. ToHType f => Proxy f -> HState HType
toHType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    HType -> HState HType
forall a. a -> StateT (Map MData ()) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HType -> HState HType) -> HType -> HState HType
forall a b. (a -> b) -> a -> b
$
      case HType
htype of
        HPrimitive md :: MData
md@(MData Text
"Char" Text
_ Text
_) ->
          MData -> HType
HPrimitive (MData -> HType) -> MData -> HType
forall a b. (a -> b) -> a -> b
$ MData
md {_mTypeName = "String"}
        HType
hta -> HType -> HType
HList HType
hta

instance ToHType Text where
  toHType :: Proxy Text -> HState HType
toHType Proxy Text
_ = Proxy String -> HState HType
forall f. ToHType f => Proxy f -> HState HType
toHType (Proxy String
forall {k} (t :: k). Proxy t
Proxy :: Proxy String)

mkHType :: (Typeable a) => Proxy a -> HType
mkHType :: forall {k} (a :: k). Typeable a => Proxy a -> HType
mkHType Proxy a
p =
  let tname :: TyCon
tname = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
p
   in MData -> HType
HPrimitive
        (Text -> Text -> Text -> MData
MData
           (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConName TyCon
tname)
           (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConModule TyCon
tname)
           (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConPackage TyCon
tname))