{- |
Code generate type definitions in any language based on Haskell types.
-}
module FieldsAndCases
( matchRecordLikeDataType,
isEnumWithoutData,
ToTypeDefs (..),
ToTypeDef (..),
IsTypeExpr (..),
TypeExpr (..),
TypeDef (..),
Case (..),
CaseArgs (..),
Field (..),
PositionalArg (..),
QualifiedName (..),
)
where
import Data.String.Conversions (cs)
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)
import Relude
-- | Haskell type definition.
data TypeDef texpr = TypeDef
{ qualifiedName :: QualifiedName,
cases :: [Case texpr]
}
deriving (Show, Eq)
-- | Haskell type constructor.
data Case texpr = Case
{ tagName :: Text,
caseArgs :: Maybe (CaseArgs texpr)
}
deriving (Show, Eq)
-- | Haskell type constructor arguments.
data CaseArgs texpr
= CasePositionalArgs [PositionalArg texpr]
| CaseFields [Field texpr]
deriving (Show, Eq)
-- | Haskell type labeled field.
data Field texpr = Field
{ fieldName :: Text,
fieldType :: texpr
}
deriving (Show, Eq)
-- | Haskell type positional field.
newtype PositionalArg texpr = PositionalArg
{ fieldType :: texpr
}
deriving (Show, Eq)
-- | Haskell type qualified name.
data QualifiedName = QualifiedName
{ moduleName :: Text,
typeName :: Text
}
deriving (Show, Eq)
-- | Data types with a single constructor and labeled fields
-- | are considered record-like.
matchRecordLikeDataType :: TypeDef texpr -> Maybe (Text, [Field texpr])
matchRecordLikeDataType (TypeDef {qualifiedName = QualifiedName {typeName}, cases}) =
case cases of
[Case {tagName, caseArgs = Just (CaseFields fields)}]
| typeName == tagName -> Just (typeName, fields)
_ -> Nothing
-- | Data types with all of their constructors having no arguments
isEnumWithoutData :: TypeDef texpr -> Bool
isEnumWithoutData (TypeDef {qualifiedName = QualifiedName {typeName}, cases}) =
all isEnumCase cases
where
isEnumCase (Case {caseArgs = Nothing}) = True
isEnumCase _ = False
---
-- | Like 'ToTypeDef' but for a list of types.
class ToTypeDefs (xs :: [Type]) texpr where
toTypeDefs :: [TypeDef texpr]
instance ToTypeDefs '[] texpr where
toTypeDefs = []
instance (ToTypeDef x texpr, ToTypeDefs xs texpr) => ToTypeDefs (x ': xs) texpr where
toTypeDefs = toTypeDef @x @texpr : toTypeDefs @xs @texpr
---
-- | A class of types which can be used as type expressions.
class IsTypeExpr texpr where
typeRef :: QualifiedName -> texpr
instance IsTypeExpr Text where
typeRef (QualifiedName {typeName}) = fromString $ cs typeName
--- ToTypeRef ---
-- | Describes how to convert a type to a type expression of a specific language.
class TypeExpr a texpr where
typeExpr :: texpr
default typeExpr ::
(IsTypeExpr texpr, Generic a, GToTypeRef (Rep a)) => texpr
typeExpr =
typeRef $ gToTypeRef $ getRep (Proxy :: Proxy a)
class GToTypeRef rep where
gToTypeRef :: rep a -> QualifiedName
-- Match Data Type
instance
(KnownSymbol typeName, KnownSymbol moduleName) =>
GToTypeRef
(M1 {- MetaInfo -} D {- DataType -} ('MetaData typeName moduleName packageName isNewtype) cases)
where
gToTypeRef _ = result
where
moduleName :: Text
moduleName = fromString $ symbolVal (Proxy @moduleName)
typeName :: Text
typeName = fromString $ symbolVal (Proxy @typeName)
result :: QualifiedName
result = QualifiedName {moduleName, typeName}
--- ToTypeDef ---
-- | Get the type definition of a type.
class ToTypeDef a texpr where
toTypeDef :: TypeDef texpr
instance (Generic a, GToTypeDef (Rep a) (TypeDef texpr)) => ToTypeDef a texpr where
toTypeDef = gToTypeDef $ getRep (Proxy :: Proxy a)
class GToTypeDef rep def where
gToTypeDef :: rep a -> def
-- Match Data Type
instance
(GToTypeDef cases [Case texpr], KnownSymbol typeName, KnownSymbol moduleName) =>
GToTypeDef
(M1 {- MetaInfo -} D {- DataType -} ('MetaData typeName moduleName packageName isNewtype) cases)
(TypeDef texpr)
where
gToTypeDef _ = result
where
cases :: [Case texpr]
cases = gToTypeDef (error "no value" :: cases x)
moduleName :: Text
moduleName = fromString $ symbolVal (Proxy @moduleName)
typeName :: Text
typeName = fromString $ symbolVal (Proxy @typeName)
qualifiedName :: QualifiedName
qualifiedName = QualifiedName {moduleName, typeName}
result :: TypeDef texpr
result = TypeDef qualifiedName (coerce cases)
-- Match Sum
instance
(GToTypeDef lhs [Case texpr], GToTypeDef rhs [Case texpr]) =>
GToTypeDef
(lhs :+: rhs)
[Case texpr]
where
gToTypeDef _ = result
where
lhs :: [Case texpr]
lhs = gToTypeDef (error "no value" :: lhs x)
rhs :: [Case texpr]
rhs = gToTypeDef (error "no value" :: rhs x)
result :: [Case texpr]
result = lhs <> rhs
-- Match Constructor with fields
instance
{-# OVERLAPPABLE #-}
(KnownSymbol ctorName, GToTypeDef fields [Field texpr]) =>
GToTypeDef
(M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'True {- hasSelectors -}) fields)
[Case texpr]
where
gToTypeDef _ = result
where
fields :: [Field texpr]
fields = gToTypeDef (error "no value" :: fields x)
tagName :: Text
tagName = fromString $ symbolVal (Proxy @ctorName)
case_ :: Case texpr
case_ =
Case
{ tagName,
caseArgs = Just $ CaseFields (coerce fields)
}
result :: [Case texpr]
result = coerce [case_]
-- Match Constructor with positional fields
instance
{-# OVERLAPPABLE #-}
(KnownSymbol ctorName, GToTypeDef fields [PositionalArg texpr]) =>
GToTypeDef
(M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'False {- hasSelectors -}) fields)
[Case texpr]
where
gToTypeDef _ = result
where
tagName :: Text
tagName = fromString $ symbolVal (Proxy @ctorName)
fields :: [PositionalArg texpr]
fields = gToTypeDef (error "no value" :: fields x)
case_ :: Case texpr
case_ =
Case
{ tagName,
caseArgs = Just $ CasePositionalArgs (coerce fields)
}
result :: [Case texpr]
result = coerce [case_]
-- Match Constructor without fields
instance
{-# OVERLAPPABLE #-}
(KnownSymbol ctorName) =>
GToTypeDef
(M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'False {- hasSelectors -}) U1 {- Unit -})
[Case texpr]
where
gToTypeDef _ = result
where
tagName :: Text
tagName = fromString $ symbolVal (Proxy @ctorName)
case_ :: Case texpr
case_ = Case {tagName, caseArgs = Nothing}
result :: [Case texpr]
result = coerce [case_]
-- Match Product
instance
(GToTypeDef lhs fields, GToTypeDef rhs fields, Semigroup fields) =>
GToTypeDef
(lhs :*: rhs)
fields
where
gToTypeDef _ = result
where
lhs :: fields
lhs = gToTypeDef (error "no value" :: lhs x)
rhs :: fields
rhs = gToTypeDef (error "no value" :: rhs x)
result :: fields
result = lhs <> rhs
-- Match Field
instance
{-# OVERLAPPABLE #-}
(TypeExpr a texpr, KnownSymbol fieldName) =>
GToTypeDef
(M1 {- MetaInfo -} S {- Selector -} ('MetaSel ('Just fieldName) srcUnpackedness srcStrictness inferedStrictness) (K1 R a))
[Field texpr]
where
gToTypeDef _ = result
where
fieldName :: Text
fieldName = fromString $ symbolVal (Proxy @fieldName)
fieldType :: texpr
fieldType = typeExpr @a @texpr
field :: Field texpr
field = Field {fieldName, fieldType}
result :: [Field texpr]
result = coerce [field]
-- Match Positional Field
instance
{-# OVERLAPPABLE #-}
(TypeExpr a texpr) =>
GToTypeDef
(M1 {- MetaInfo -} S {- Selector -} ('MetaSel 'Nothing srcUnpackedness srcStrictness inferedStrictness) (K1 R a))
[PositionalArg texpr]
where
gToTypeDef _ = result
where
fieldType :: texpr
fieldType = typeExpr @a @texpr
field :: PositionalArg texpr
field = PositionalArg {fieldType}
result :: [PositionalArg texpr]
result = coerce [field]
--- Utils ---
-- Function to get the Rep of a type without a value
getRep :: forall rep a x. (Generic a, Rep a ~ rep) => Proxy a -> rep x
getRep _ = from (error "no value" :: a)