{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Elm.Generic
(
Elm (..)
, elmRef
, elmNewtype
, GenericElmDefinition (..)
, GenericElmConstructors (..)
, GenericElmFields (..)
, GenericConstructor (..)
, toElmConstructor
, CodeGenOptions (..)
, defaultCodeGenOptions
, HasNoTypeVars
, TypeVarsError
, HasLessThanEightUnnamedFields
, FieldsError
, CheckFields
, Max
, HasNoNamedSum
, NamedSumError
, CheckNamedSum
, CheckConst
, ElmStreetGenericConstraints
, stripTypeNamePrefix
) where
import Data.Aeson (Value)
import Data.Char (isLower, toLower)
import Data.Int (Int16, Int32, Int8)
import Data.Kind (Constraint, Type)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Type.Reflection (Typeable, typeRep)
import Data.Time.Clock (UTCTime)
import Data.Type.Bool (If, type (||))
import Data.Void (Void)
import Data.Word (Word16, Word32, Word8)
import GHC.Generics (C1, Constructor (..), D1, Datatype (..), Generic (..), M1 (..), Meta (..),
Rec0, S1, Selector (..), U1, (:*:), (:+:))
import GHC.TypeLits (ErrorMessage (..), Nat, TypeError)
import GHC.TypeNats (type (+), type (<=?))
import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..),
ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), definitionToRef)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT (Text)
import qualified GHC.Generics as Generic (from)
class Elm a where
toElmDefinition :: Proxy a -> ElmDefinition
default toElmDefinition
:: (ElmStreetGenericConstraints a, Typeable a)
=> Proxy a
-> ElmDefinition
toElmDefinition Proxy a
_ = forall k (f :: k -> *) (a :: k).
GenericElmDefinition f =>
CodeGenOptions -> f a -> ElmDefinition
genericToElmDefinition (forall {k} (a :: k). Typeable a => CodeGenOptions
defaultCodeGenOptions @a)
forall a b. (a -> b) -> a -> b
$ forall a x. Generic a => a -> Rep a x
Generic.from (forall a. HasCallStack => [Char] -> a
error [Char]
"Proxy for generic elm was evaluated" :: a)
elmRef :: forall a . Elm a => TypeRef
elmRef :: forall a. Elm a => TypeRef
elmRef = ElmDefinition -> TypeRef
definitionToRef forall a b. (a -> b) -> a -> b
$ forall a. Elm a => Proxy a -> ElmDefinition
toElmDefinition forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a
instance Elm () where toElmDefinition :: Proxy () -> ElmDefinition
toElmDefinition Proxy ()
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmUnit
instance Elm Void where toElmDefinition :: Proxy Void -> ElmDefinition
toElmDefinition Proxy Void
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmNever
instance Elm Bool where toElmDefinition :: Proxy Bool -> ElmDefinition
toElmDefinition Proxy Bool
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmBool
instance Elm Char where toElmDefinition :: Proxy Char -> ElmDefinition
toElmDefinition Proxy Char
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmChar
instance Elm Int where toElmDefinition :: Proxy Int -> ElmDefinition
toElmDefinition Proxy Int
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Int8 where toElmDefinition :: Proxy Int8 -> ElmDefinition
toElmDefinition Proxy Int8
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Int16 where toElmDefinition :: Proxy Int16 -> ElmDefinition
toElmDefinition Proxy Int16
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Int32 where toElmDefinition :: Proxy Int32 -> ElmDefinition
toElmDefinition Proxy Int32
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Word where toElmDefinition :: Proxy Word -> ElmDefinition
toElmDefinition Proxy Word
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Word8 where toElmDefinition :: Proxy Word8 -> ElmDefinition
toElmDefinition Proxy Word8
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Word16 where toElmDefinition :: Proxy Word16 -> ElmDefinition
toElmDefinition Proxy Word16
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Word32 where toElmDefinition :: Proxy Word32 -> ElmDefinition
toElmDefinition Proxy Word32
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmInt
instance Elm Float where toElmDefinition :: Proxy Float -> ElmDefinition
toElmDefinition Proxy Float
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmFloat
instance Elm Double where toElmDefinition :: Proxy Double -> ElmDefinition
toElmDefinition Proxy Double
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmFloat
instance Elm Text where toElmDefinition :: Proxy Text -> ElmDefinition
toElmDefinition Proxy Text
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmString
instance Elm LT.Text where toElmDefinition :: Proxy Text -> ElmDefinition
toElmDefinition Proxy Text
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmString
instance Elm Value where toElmDefinition :: Proxy Value -> ElmDefinition
toElmDefinition Proxy Value
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmValue
instance Elm UTCTime where toElmDefinition :: Proxy UTCTime -> ElmDefinition
toElmDefinition Proxy UTCTime
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmTime
instance Elm a => Elm (Maybe a) where
toElmDefinition :: Proxy (Maybe a) -> ElmDefinition
toElmDefinition Proxy (Maybe a)
_ = ElmPrim -> ElmDefinition
DefPrim forall a b. (a -> b) -> a -> b
$ TypeRef -> ElmPrim
ElmMaybe forall a b. (a -> b) -> a -> b
$ forall a. Elm a => TypeRef
elmRef @a
instance (Elm a, Elm b) => Elm (Either a b) where
toElmDefinition :: Proxy (Either a b) -> ElmDefinition
toElmDefinition Proxy (Either a b)
_ = ElmPrim -> ElmDefinition
DefPrim forall a b. (a -> b) -> a -> b
$ TypeRef -> TypeRef -> ElmPrim
ElmResult (forall a. Elm a => TypeRef
elmRef @a) (forall a. Elm a => TypeRef
elmRef @b)
instance (Elm a, Elm b) => Elm (a, b) where
toElmDefinition :: Proxy (a, b) -> ElmDefinition
toElmDefinition Proxy (a, b)
_ = ElmPrim -> ElmDefinition
DefPrim forall a b. (a -> b) -> a -> b
$ TypeRef -> TypeRef -> ElmPrim
ElmPair (forall a. Elm a => TypeRef
elmRef @a) (forall a. Elm a => TypeRef
elmRef @b)
instance (Elm a, Elm b, Elm c) => Elm (a, b, c) where
toElmDefinition :: Proxy (a, b, c) -> ElmDefinition
toElmDefinition Proxy (a, b, c)
_ = ElmPrim -> ElmDefinition
DefPrim forall a b. (a -> b) -> a -> b
$ TypeRef -> TypeRef -> TypeRef -> ElmPrim
ElmTriple (forall a. Elm a => TypeRef
elmRef @a) (forall a. Elm a => TypeRef
elmRef @b) (forall a. Elm a => TypeRef
elmRef @c)
instance Elm a => Elm [a] where
toElmDefinition :: Proxy [a] -> ElmDefinition
toElmDefinition Proxy [a]
_ = ElmPrim -> ElmDefinition
DefPrim forall a b. (a -> b) -> a -> b
$ TypeRef -> ElmPrim
ElmList (forall a. Elm a => TypeRef
elmRef @a)
instance {-# OVERLAPPING #-} Elm String where
toElmDefinition :: Proxy [Char] -> ElmDefinition
toElmDefinition Proxy [Char]
_ = ElmPrim -> ElmDefinition
DefPrim ElmPrim
ElmString
instance Elm a => Elm (NonEmpty a) where
toElmDefinition :: Proxy (NonEmpty a) -> ElmDefinition
toElmDefinition Proxy (NonEmpty a)
_ = ElmPrim -> ElmDefinition
DefPrim forall a b. (a -> b) -> a -> b
$ TypeRef -> ElmPrim
ElmNonEmptyPair (forall a. Elm a => TypeRef
elmRef @a)
elmNewtype :: forall a . Elm a => Text -> Text -> ElmDefinition
elmNewtype :: forall a. Elm a => Text -> Text -> ElmDefinition
elmNewtype Text
typeName Text
fieldName = ElmRecord -> ElmDefinition
DefRecord forall a b. (a -> b) -> a -> b
$ ElmRecord
{ elmRecordName :: Text
elmRecordName = Text
typeName
, elmRecordFields :: NonEmpty ElmRecordField
elmRecordFields = TypeRef -> Text -> ElmRecordField
ElmRecordField (forall a. Elm a => TypeRef
elmRef @a) Text
fieldName forall a. a -> [a] -> NonEmpty a
:| []
, elmRecordIsNewtype :: Bool
elmRecordIsNewtype = Bool
True
}
class GenericElmDefinition (f :: k -> Type) where
genericToElmDefinition :: CodeGenOptions -> f a -> ElmDefinition
instance (Datatype d, GenericElmConstructors f) => GenericElmDefinition (D1 d f) where
genericToElmDefinition :: forall (a :: k). CodeGenOptions -> D1 d f a -> ElmDefinition
genericToElmDefinition CodeGenOptions
options D1 d f a
datatype = case forall k (f :: k -> *) (a :: k).
GenericElmConstructors f =>
CodeGenOptions -> f a -> NonEmpty GenericConstructor
genericToElmConstructors CodeGenOptions
options (forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 D1 d f a
datatype) of
GenericConstructor
c :| [] -> case GenericConstructor
-> Either (NonEmpty ElmRecordField) ElmConstructor
toElmConstructor GenericConstructor
c of
Left NonEmpty ElmRecordField
fields -> ElmRecord -> ElmDefinition
DefRecord forall a b. (a -> b) -> a -> b
$ Text -> NonEmpty ElmRecordField -> Bool -> ElmRecord
ElmRecord Text
typeName NonEmpty ElmRecordField
fields Bool
elmIsNewtype
Right ElmConstructor
ctor -> ElmType -> ElmDefinition
DefType forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Bool -> NonEmpty ElmConstructor -> ElmType
ElmType Text
typeName [] Bool
elmIsNewtype (ElmConstructor
ctor forall a. a -> [a] -> NonEmpty a
:| [])
GenericConstructor
c :| [GenericConstructor]
cs -> case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall l r. Either l r -> Maybe r
rightToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericConstructor
-> Either (NonEmpty ElmRecordField) ElmConstructor
toElmConstructor) (GenericConstructor
c forall a. a -> [a] -> NonEmpty a
:| [GenericConstructor]
cs) of
Maybe (NonEmpty ElmConstructor)
Nothing -> ElmType -> ElmDefinition
DefType forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Bool -> NonEmpty ElmConstructor -> ElmType
ElmType (Text
"ERROR_" forall a. Semigroup a => a -> a -> a
<> Text
typeName) [] Bool
False (Text -> [TypeRef] -> ElmConstructor
ElmConstructor Text
"ERROR" [] forall a. a -> [a] -> NonEmpty a
:| [])
Just NonEmpty ElmConstructor
ctors -> ElmType -> ElmDefinition
DefType forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Bool -> NonEmpty ElmConstructor -> ElmType
ElmType Text
typeName [] Bool
elmIsNewtype NonEmpty ElmConstructor
ctors
where
typeName :: Text
typeName :: Text
typeName = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> [Char]
datatypeName D1 d f a
datatype
elmIsNewtype :: Bool
elmIsNewtype :: Bool
elmIsNewtype = forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> Bool
isNewtype D1 d f a
datatype
rightToMaybe :: Either l r -> Maybe r
rightToMaybe :: forall l r. Either l r -> Maybe r
rightToMaybe = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
data GenericConstructor = GenericConstructor
{ GenericConstructor -> Text
genericConstructorName :: !Text
, GenericConstructor -> [(TypeRef, Maybe Text)]
genericConstructorFields :: ![(TypeRef, Maybe Text)]
}
toElmConstructor :: GenericConstructor -> Either (NonEmpty ElmRecordField) ElmConstructor
toElmConstructor :: GenericConstructor
-> Either (NonEmpty ElmRecordField) ElmConstructor
toElmConstructor GenericConstructor{[(TypeRef, Maybe Text)]
Text
genericConstructorFields :: [(TypeRef, Maybe Text)]
genericConstructorName :: Text
genericConstructorFields :: GenericConstructor -> [(TypeRef, Maybe Text)]
genericConstructorName :: GenericConstructor -> Text
..} = case [(TypeRef, Maybe Text)]
genericConstructorFields of
[] -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> [TypeRef] -> ElmConstructor
ElmConstructor Text
genericConstructorName []
(TypeRef, Maybe Text)
f:[(TypeRef, Maybe Text)]
fs -> case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (TypeRef, Maybe Text) -> Maybe ElmRecordField
toRecordField ((TypeRef, Maybe Text)
f forall a. a -> [a] -> NonEmpty a
:| [(TypeRef, Maybe Text)]
fs) of
Maybe (NonEmpty ElmRecordField)
Nothing -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> [TypeRef] -> ElmConstructor
ElmConstructor Text
genericConstructorName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TypeRef, Maybe Text)]
genericConstructorFields
Just NonEmpty ElmRecordField
fields -> forall a b. a -> Either a b
Left NonEmpty ElmRecordField
fields
where
toRecordField :: (TypeRef, Maybe Text) -> Maybe ElmRecordField
toRecordField :: (TypeRef, Maybe Text) -> Maybe ElmRecordField
toRecordField (TypeRef
typeRef, Maybe Text
maybeFieldName) = TypeRef -> Text -> ElmRecordField
ElmRecordField TypeRef
typeRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybeFieldName
class GenericElmConstructors (f :: k -> Type) where
genericToElmConstructors
:: CodeGenOptions
-> f a
-> NonEmpty GenericConstructor
instance (GenericElmConstructors f, GenericElmConstructors g) => GenericElmConstructors (f :+: g) where
genericToElmConstructors :: forall (a :: k).
CodeGenOptions -> (:+:) f g a -> NonEmpty GenericConstructor
genericToElmConstructors CodeGenOptions
options (:+:) f g a
_ =
forall k (f :: k -> *) (a :: k).
GenericElmConstructors f =>
CodeGenOptions -> f a -> NonEmpty GenericConstructor
genericToElmConstructors CodeGenOptions
options (forall a. HasCallStack => [Char] -> a
error [Char]
"'f :+:' is evaluated" :: f p)
forall a. Semigroup a => a -> a -> a
<> forall k (f :: k -> *) (a :: k).
GenericElmConstructors f =>
CodeGenOptions -> f a -> NonEmpty GenericConstructor
genericToElmConstructors CodeGenOptions
options (forall a. HasCallStack => [Char] -> a
error [Char]
"':+: g' is evaluated" :: g p)
instance (Constructor c, GenericElmFields f) => GenericElmConstructors (C1 c f) where
genericToElmConstructors :: forall (a :: k).
CodeGenOptions -> C1 c f a -> NonEmpty GenericConstructor
genericToElmConstructors CodeGenOptions
options C1 c f a
constructor = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(TypeRef, Maybe Text)] -> GenericConstructor
GenericConstructor
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName C1 c f a
constructor)
(forall k (f :: k -> *) (a :: k).
GenericElmFields f =>
CodeGenOptions -> f a -> [(TypeRef, Maybe Text)]
genericToElmFields CodeGenOptions
options forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 C1 c f a
constructor)
class GenericElmFields (f :: k -> Type) where
genericToElmFields
:: CodeGenOptions
-> f a
-> [(TypeRef, Maybe Text)]
instance (GenericElmFields f, GenericElmFields g) => GenericElmFields (f :*: g) where
genericToElmFields :: forall (a :: k).
CodeGenOptions -> (:*:) f g a -> [(TypeRef, Maybe Text)]
genericToElmFields CodeGenOptions
options (:*:) f g a
_ =
forall k (f :: k -> *) (a :: k).
GenericElmFields f =>
CodeGenOptions -> f a -> [(TypeRef, Maybe Text)]
genericToElmFields CodeGenOptions
options (forall a. HasCallStack => [Char] -> a
error [Char]
"'f :*:' is evaluated" :: f p)
forall a. Semigroup a => a -> a -> a
<> forall k (f :: k -> *) (a :: k).
GenericElmFields f =>
CodeGenOptions -> f a -> [(TypeRef, Maybe Text)]
genericToElmFields CodeGenOptions
options (forall a. HasCallStack => [Char] -> a
error [Char]
"':*: g' is evaluated" :: g p)
instance GenericElmFields U1 where
genericToElmFields :: forall (a :: k). CodeGenOptions -> U1 a -> [(TypeRef, Maybe Text)]
genericToElmFields CodeGenOptions
_ U1 a
_ = []
instance (Selector s, Elm a) => GenericElmFields (S1 s (Rec0 a)) where
genericToElmFields :: forall (a :: k).
CodeGenOptions -> S1 s (Rec0 a) a -> [(TypeRef, Maybe Text)]
genericToElmFields CodeGenOptions
options S1 s (Rec0 a) a
selector = case forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName S1 s (Rec0 a) a
selector of
[Char]
"" -> [(forall a. Elm a => TypeRef
elmRef @a, forall a. Maybe a
Nothing)]
[Char]
name -> [(forall a. Elm a => TypeRef
elmRef @a, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CodeGenOptions -> Text -> Text
cgoFieldLabelModifier CodeGenOptions
options forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
name)]
stripTypeNamePrefix :: TypeName -> Text -> Text
stripTypeNamePrefix :: TypeName -> Text -> Text
stripTypeNamePrefix (TypeName Text
typeName) Text
fieldName =
case Text -> Text -> Maybe Text
T.stripPrefix (Text -> Text
headToLower Text
typeName) Text
fieldName of
Just Text
rest -> Text -> Text
leaveIfEmpty Text
rest
Maybe Text
Nothing -> Text -> Text
leaveIfEmpty ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isLower Text
fieldName)
where
headToLower :: Text -> Text
headToLower :: Text -> Text
headToLower Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
Maybe (Char, Text)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use 'headToLower' on empty Text"
Just (Char
x, Text
xs) -> Char -> Text -> Text
T.cons (Char -> Char
toLower Char
x) Text
xs
leaveIfEmpty :: Text -> Text
leaveIfEmpty :: Text -> Text
leaveIfEmpty Text
rest = if Text -> Bool
T.null Text
rest then Text
fieldName else Text -> Text
headToLower Text
rest
newtype CodeGenOptions = CodeGenOptions
{ CodeGenOptions -> Text -> Text
cgoFieldLabelModifier :: Text -> Text
}
defaultCodeGenOptions :: forall a. Typeable a => CodeGenOptions
defaultCodeGenOptions :: forall {k} (a :: k). Typeable a => CodeGenOptions
defaultCodeGenOptions = (Text -> Text) -> CodeGenOptions
CodeGenOptions (TypeName -> Text -> Text
stripTypeNamePrefix TypeName
typeName)
where
typeName :: TypeName
typeName :: TypeName
typeName = Text -> TypeName
TypeName forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a
type family HasNoTypeVars (f :: k) :: Constraint where
HasNoTypeVars (t a b c d e f) = TypeError (TypeVarsError t 6)
HasNoTypeVars (t a b c d e) = TypeError (TypeVarsError t 5)
HasNoTypeVars (t a b c d) = TypeError (TypeVarsError t 4)
HasNoTypeVars (t a b c) = TypeError (TypeVarsError t 3)
HasNoTypeVars (t a b) = TypeError (TypeVarsError t 2)
HasNoTypeVars (t a) = TypeError (TypeVarsError t 1)
HasNoTypeVars t = ()
type family TypeVarsError (t :: k) (n :: Nat) :: ErrorMessage where
TypeVarsError t n =
'Text "'elm-street' currently doesn't support Generic deriving of the 'Elm' typeclass"
':$$: 'Text "for data types with type variables. But '"
':<>: 'ShowType t ':<>: 'Text "' has " ':<>: 'ShowType n ':<>: 'Text " variables."
':$$: 'Text ""
':$$: 'Text "See the following issue for more details:"
':$$: 'Text " * https://github.com/Holmusk/elm-street/issues/45"
':$$: 'Text ""
type family HasLessThanEightUnnamedFields (f :: k) :: Constraint where
HasLessThanEightUnnamedFields t =
If (CheckFields (Rep t) <=? 8)
(() :: Constraint)
(TypeError (FieldsError t))
type family CheckFields (f :: k -> Type) :: Nat where
CheckFields (D1 _ f) = CheckFields f
CheckFields (f :+: g) = Max (CheckFields f) (CheckFields g)
CheckFields (C1 _ f) = CheckFields f
CheckFields (f :*: g) = CheckFields f + CheckFields g
CheckFields (S1 ('MetaSel ('Just _ ) _ _ _) _) = 0
CheckFields (S1 _ _) = 1
CheckFields _ = 0
type family Max (x :: Nat) (y :: Nat) :: Nat where
Max x y = If (x <=? y) y x
type family FieldsError (t :: k) :: ErrorMessage where
FieldsError t =
'Text "'elm-street' doesn't support Constructors with more than 8 unnamed fields."
':$$: 'Text "But '" ':<>: 'ShowType t ':<>: 'Text "' has more."
type family HasNoNamedSum (f :: k) :: Constraint where
HasNoNamedSum t =
If (CheckNamedSum (Rep t))
(TypeError (NamedSumError t))
(() :: Constraint)
type family CheckNamedSum (f :: k -> Type) :: Bool where
CheckNamedSum (D1 _ f) = CheckNamedSum f
CheckNamedSum (f :+: g) = CheckConst f || CheckConst g
CheckNamedSum _ = 'False
type family CheckConst (f :: k -> Type) :: Bool where
CheckConst (f :+: g) = CheckConst f || CheckConst g
CheckConst (C1 _ f) = CheckConst f
CheckConst (S1 ('MetaSel ('Just _ ) _ _ _) _) = 'True
CheckConst (f :*: g) = CheckConst f || CheckConst g
CheckConst _ = 'False
type family NamedSumError (t :: k) :: ErrorMessage where
NamedSumError t =
'Text "'elm-street' doesn't support Sum types with records."
':$$: 'Text "But '" ':<>: 'ShowType t ':<>: 'Text "' has records."
type ElmStreetGenericConstraints a =
( HasNoTypeVars a
, HasLessThanEightUnnamedFields a
, HasNoNamedSum a
, Generic a
, GenericElmDefinition (Rep a)
)