{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Elm.Generic
(
Elm (..)
, elmRef
, elmNewtype
, GenericElmDefinition (..)
, GenericElmConstructors (..)
, GenericElmFields (..)
, GenericConstructor (..)
, toElmConstructor
, HasNoTypeVars
, TypeVarsError
, HasLessThanEightUnnamedFields
, FieldsError
, CheckFields
, Max
, HasNoNamedSum
, NamedSumError
, CheckNamedSum
, CheckConst
, stripTypeNamePrefix
) where
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 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 (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..),
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
:: ( HasNoTypeVars a
, HasLessThanEightUnnamedFields a
, HasNoNamedSum a
, Generic a
, GenericElmDefinition (Rep a)
)
=> Proxy a
-> ElmDefinition
toElmDefinition _ = genericToElmDefinition
$ Generic.from (error "Proxy for generic elm was evaluated" :: a)
elmRef :: forall a . Elm a => TypeRef
elmRef = definitionToRef $ toElmDefinition $ Proxy @a
instance Elm () where toElmDefinition _ = DefPrim ElmUnit
instance Elm Void where toElmDefinition _ = DefPrim ElmNever
instance Elm Bool where toElmDefinition _ = DefPrim ElmBool
instance Elm Char where toElmDefinition _ = DefPrim ElmChar
instance Elm Int where toElmDefinition _ = DefPrim ElmInt
instance Elm Int8 where toElmDefinition _ = DefPrim ElmInt
instance Elm Int16 where toElmDefinition _ = DefPrim ElmInt
instance Elm Int32 where toElmDefinition _ = DefPrim ElmInt
instance Elm Word where toElmDefinition _ = DefPrim ElmInt
instance Elm Word8 where toElmDefinition _ = DefPrim ElmInt
instance Elm Word16 where toElmDefinition _ = DefPrim ElmInt
instance Elm Word32 where toElmDefinition _ = DefPrim ElmInt
instance Elm Float where toElmDefinition _ = DefPrim ElmFloat
instance Elm Double where toElmDefinition _ = DefPrim ElmFloat
instance Elm Text where toElmDefinition _ = DefPrim ElmString
instance Elm LT.Text where toElmDefinition _ = DefPrim ElmString
instance Elm UTCTime where toElmDefinition _ = DefPrim ElmTime
instance Elm a => Elm (Maybe a) where
toElmDefinition _ = DefPrim $ ElmMaybe $ elmRef @a
instance (Elm a, Elm b) => Elm (Either a b) where
toElmDefinition _ = DefPrim $ ElmResult (elmRef @a) (elmRef @b)
instance (Elm a, Elm b) => Elm (a, b) where
toElmDefinition _ = DefPrim $ ElmPair (elmRef @a) (elmRef @b)
instance (Elm a, Elm b, Elm c) => Elm (a, b, c) where
toElmDefinition _ = DefPrim $ ElmTriple (elmRef @a) (elmRef @b) (elmRef @c)
instance Elm a => Elm [a] where
toElmDefinition _ = DefPrim $ ElmList (elmRef @a)
instance Elm a => Elm (NonEmpty a) where
toElmDefinition _ = DefPrim $ ElmList (elmRef @a)
elmNewtype :: forall a . Elm a => Text -> Text -> ElmDefinition
elmNewtype typeName fieldName = DefAlias $ ElmAlias
{ elmAliasName = typeName
, elmAliasFields = ElmRecordField (elmRef @a) fieldName :| []
, elmAliasIsNewtype = True
}
class GenericElmDefinition (f :: k -> Type) where
genericToElmDefinition :: f a -> ElmDefinition
instance (Datatype d, GenericElmConstructors f) => GenericElmDefinition (D1 d f) where
genericToElmDefinition datatype = case genericToElmConstructors (TypeName typeName) (unM1 datatype) of
c :| [] -> case toElmConstructor c of
Left fields -> DefAlias $ ElmAlias typeName fields elmIsNewtype
Right ctor -> DefType $ ElmType typeName [] elmIsNewtype (ctor :| [])
c :| cs -> case traverse (rightToMaybe . toElmConstructor) (c :| cs) of
Nothing -> DefType $ ElmType ("ERROR_" <> typeName) [] False (ElmConstructor "ERROR" [] :| [])
Just ctors -> DefType $ ElmType typeName [] elmIsNewtype ctors
where
typeName :: Text
typeName = T.pack $ datatypeName datatype
elmIsNewtype :: Bool
elmIsNewtype = isNewtype datatype
rightToMaybe :: Either l r -> Maybe r
rightToMaybe = either (const Nothing) Just
data GenericConstructor = GenericConstructor
{ genericConstructorName :: !Text
, genericConstructorFields :: ![(TypeRef, Maybe Text)]
}
toElmConstructor :: GenericConstructor -> Either (NonEmpty ElmRecordField) ElmConstructor
toElmConstructor GenericConstructor{..} = case genericConstructorFields of
[] -> Right $ ElmConstructor genericConstructorName []
f:fs -> case traverse toRecordField (f :| fs) of
Nothing -> Right $ ElmConstructor genericConstructorName $ map fst genericConstructorFields
Just fields -> Left fields
where
toRecordField :: (TypeRef, Maybe Text) -> Maybe ElmRecordField
toRecordField (typeRef, maybeFieldName) = ElmRecordField typeRef <$> maybeFieldName
class GenericElmConstructors (f :: k -> Type) where
genericToElmConstructors
:: TypeName
-> f a
-> NonEmpty GenericConstructor
instance (GenericElmConstructors f, GenericElmConstructors g) => GenericElmConstructors (f :+: g) where
genericToElmConstructors name _ =
genericToElmConstructors name (error "'f :+:' is evaluated" :: f p)
<> genericToElmConstructors name (error "':+: g' is evaluated" :: g p)
instance (Constructor c, GenericElmFields f) => GenericElmConstructors (C1 c f) where
genericToElmConstructors name constructor = pure $ GenericConstructor
(T.pack $ conName constructor)
(genericToElmFields name $ unM1 constructor)
class GenericElmFields (f :: k -> Type) where
genericToElmFields
:: TypeName
-> f a
-> [(TypeRef, Maybe Text)]
instance (GenericElmFields f, GenericElmFields g) => GenericElmFields (f :*: g) where
genericToElmFields name _ =
genericToElmFields name (error "'f :*:' is evaluated" :: f p)
<> genericToElmFields name (error "':*: g' is evaluated" :: g p)
instance GenericElmFields U1 where
genericToElmFields _ _ = []
instance (Selector s, Elm a) => GenericElmFields (S1 s (Rec0 a)) where
genericToElmFields typeName selector = case selName selector of
"" -> [(elmRef @a, Nothing)]
name -> [(elmRef @a, Just $ stripTypeNamePrefix typeName $ T.pack name)]
stripTypeNamePrefix :: TypeName -> Text -> Text
stripTypeNamePrefix (TypeName typeName) fieldName =
case T.stripPrefix (headToLower typeName) fieldName of
Just rest -> leaveIfEmpty rest
Nothing -> leaveIfEmpty (T.dropWhile isLower fieldName)
where
headToLower :: Text -> Text
headToLower t = case T.uncons t of
Nothing -> error "Cannot use 'headToLower' on empty Text"
Just (x, xs) -> T.cons (toLower x) xs
leaveIfEmpty :: Text -> Text
leaveIfEmpty rest = if T.null rest then fieldName else headToLower rest
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."