{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CName] -> ShowS
$cshowList :: [CName] -> ShowS
show :: CName -> String
$cshow :: CName -> String
showsPrec :: Int -> CName -> ShowS
$cshowsPrec :: Int -> CName -> ShowS
Show)

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

data TypeVar
  = Used Name
  | Phantom Name
  deriving (TypeVar -> TypeVar -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeVar -> TypeVar -> Bool
$c/= :: TypeVar -> TypeVar -> Bool
== :: TypeVar -> TypeVar -> Bool
$c== :: TypeVar -> TypeVar -> Bool
Eq, Int -> TypeVar -> ShowS
[TypeVar] -> ShowS
TypeVar -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeVar] -> ShowS
$cshowList :: [TypeVar] -> ShowS
show :: TypeVar -> String
$cshow :: TypeVar -> String
showsPrec :: Int -> TypeVar -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UDefData] -> ShowS
$cshowList :: [UDefData] -> ShowS
show :: UDefData -> String
$cshow :: UDefData -> String
showsPrec :: Int -> UDefData -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HType] -> ShowS
$cshowList :: [HType] -> ShowS
show :: HType -> String
$cshow :: HType -> String
showsPrec :: Int -> HType -> ShowS
$cshowsPrec :: Int -> 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)
_ = forall f. ToHType f => Proxy f -> HState HType
toHType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) forall a. a -> [a] -> [a]
: forall {k} (f :: k). ToHTArgs f => Proxy f -> [HState HType]
toHTArgs (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 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall {k} (f :: k). ToHTArgs f => Proxy f -> [HState HType]
toHTArgs (forall {k} (t :: k). Proxy t
Proxy :: Proxy (ExtractTArgs f)))
    HType
htype <- forall (f :: * -> *). ToHType_ f => Proxy f -> HState HType
toHType_ (forall {k} (t :: k). Proxy t
Proxy :: (Proxy (Rep f)))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      case HType
htype of
        HUDef UDefData
ud -> UDefData -> HType
HUDef forall a b. (a -> b) -> a -> b
$ UDefData
ud {udefdTypeArgs :: [HType]
udefdTypeArgs = forall a. [a] -> [a]
DL.reverse [HType]
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 forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy a1))
            (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy a2))
            (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy a3))
     in do Map MData ()
seen <- forall s (m :: * -> *). MonadState s m => m s
get
           case forall k a. Ord k => k -> Map k a -> Maybe a
DMS.lookup MData
mdata Map MData ()
seen of
             Just ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MData -> HType
HRecursive MData
mdata
             Maybe ()
Nothing -> do
               case Text -> Maybe Int
isTuple forall a b. (a -> b) -> a -> b
$ MData -> Text
_mTypeName MData
mdata of
                 Just Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                 Maybe Int
Nothing -> forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
DMS.insert MData
mdata () Map MData ()
seen
               [HConstructor]
cons_ <- forall (f :: * -> *).
ToHConstructor_ f =>
Proxy f -> HState [HConstructor]
toHConstructor_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
               forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ UDefData -> HType
HUDef 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 forall a. Eq a => a -> a -> Bool
== Char
'('
        then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
DL.length forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
',') Text
t
        else forall a. Maybe a
Nothing
    Maybe (Char, Text)
_ -> forall a. Maybe a
Nothing

instance ToHConstructor_ V1 where
  toHConstructor_ :: Proxy V1 -> HState [HConstructor]
toHConstructor_ Proxy V1
_ = 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 <- forall (f :: * -> *). ToHField_ f => Proxy f -> HState [HField]
toHField_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy s)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [CName -> [HField] -> HConstructor
HConstructor (Text -> CName
CName forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy cname)) [HField]
hfield]

instance ToHField_ U1 where
  toHField_ :: Proxy U1 -> HState [HField]
toHField_ Proxy U1
_ = 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 <- forall (f :: * -> *). ToHType_ f => Proxy f -> HState HType
toHType_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy w)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Text -> HType -> HField
HField (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (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 <- forall (f :: * -> *). ToHType_ f => Proxy f -> HState HType
toHType_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy w)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Text -> HType -> HField
HField 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 <- forall (f :: * -> *). ToHField_ f => Proxy f -> HState [HField]
toHField_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    [HField]
hfield2 <- forall (f :: * -> *). ToHField_ f => Proxy f -> HState [HField]
toHField_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [HField]
hfield1 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 <- forall (f :: * -> *).
ToHConstructor_ f =>
Proxy f -> HState [HConstructor]
toHConstructor_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    [HConstructor]
rhs <- forall (f :: * -> *).
ToHConstructor_ f =>
Proxy f -> HState [HConstructor]
toHConstructor_ (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [HConstructor]
lhs 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)
_ = forall f. ToHType f => Proxy f -> HState HType
toHType (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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 <- forall f. ToHType f => Proxy f -> HState HType
toHType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall f. ToHType f => Proxy f -> HState HType
toHType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      case HType
htype of
        HPrimitive md :: MData
md@(MData Text
"Char" Text
_ Text
_) ->
          MData -> HType
HPrimitive forall a b. (a -> b) -> a -> b
$ MData
md {_mTypeName :: Text
_mTypeName = Text
"String"}
        HType
hta -> HType -> HType
HList HType
hta

instance ToHType Text where
  toHType :: Proxy Text -> HState HType
toHType Proxy Text
_ = forall f. ToHType f => Proxy f -> HState HType
toHType (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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConName TyCon
tname)
           (String -> Text
pack forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConModule TyCon
tname)
           (String -> Text
pack forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConPackage TyCon
tname))