{-# language
AllowAmbiguousTypes
, BangPatterns
, DataKinds
, DeriveFoldable
, DeriveFunctor
, DeriveGeneric
, DeriveTraversable
, DerivingStrategies
, FlexibleInstances
, LambdaCase
, MultiWayIf
, NamedFieldPuns
, OverloadedStrings
, RecordWildCards
, ScopedTypeVariables
, TemplateHaskell
, TypeApplications
, TypeFamilies
, TypeOperators
, UndecidableInstances
, ViewPatterns
#-}
{-# options_ghc
-Wall
-fno-warn-duplicate-exports
#-}
module Shwifty
(
ToSwift(..)
, ToSwiftData(..)
, getShwifty
, getShwiftyWith
, getShwiftyWithTags
, getShwiftyCodec
, getShwiftyCodecTags
, Ty(..)
, SwiftData(..)
, Protocol(..)
, Options
, fieldLabelModifier
, constructorModifier
, optionalExpand
, generateToSwift
, generateToSwiftData
, dataProtocols
, dataRawValue
, typeAlias
, newtypeTag
, lowerFirstCase
, lowerFirstField
, omitFields
, omitCases
, makeBase
, defaultOptions
, Codec(..)
, ModifyOptions(..)
, AsIs
, type (&)
, Label(..)
, Drop
, DontGenerate
, Implement
, RawValue
, CanBeRawValue
, TypeAlias
, NewtypeTag
, DontLowercase
, OmitField
, OmitCase
, MakeBase
, prettyTy
, prettySwiftData
, X
) where
import Control.Monad.Except
import Data.Foldable (foldlM,foldr',foldl')
import Data.Functor ((<&>))
import Data.List.NonEmpty ((<|), NonEmpty(..))
import Data.Maybe (mapMaybe, catMaybes)
import Data.Proxy (Proxy(..))
import Data.Void (Void)
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Language.Haskell.TH hiding (stringE)
import Language.Haskell.TH.Datatype
import Prelude hiding (Enum(..))
import qualified Data.Char as Char
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import qualified Data.Text as TS
import Shwifty.Class
import Shwifty.Codec
import Shwifty.Pretty
import Shwifty.Types
defaultOptions :: Options
defaultOptions = Options
{ typeConstructorModifier = id
, fieldLabelModifier = id
, constructorModifier = id
, optionalExpand = False
, generateToSwift = True
, generateToSwiftData = True
, dataProtocols = []
, dataRawValue = Nothing
, typeAlias = False
, newtypeTag = False
, lowerFirstField = True
, lowerFirstCase = True
, omitFields = []
, omitCases = []
, makeBase = (False, Nothing, [])
}
data SingSymbol (x :: Symbol)
instance KnownSymbol x => ToSwift (SingSymbol x) where
toSwift _ = Poly (symbolVal (Proxy @x))
type X = Void
ensureEnabled :: Extension -> ShwiftyM ()
ensureEnabled ext = do
enabled <- lift $ isExtEnabled ext
unless enabled $ do
throwError $ ExtensionNotEnabled ext
getShwifty :: Name -> Q [Dec]
getShwifty = getShwiftyWith defaultOptions
getShwiftyWith :: Options -> Name -> Q [Dec]
getShwiftyWith o n = getShwiftyWithTags o [] n
data NewtypeInfo = NewtypeInfo
{ newtypeName :: Name
, newtypeVars :: [TyVarBndr]
, newtypeInstTypes :: [Type]
, newtypeVariant :: DatatypeVariant
, newtypeCon :: ConstructorInfo
}
reifyNewtype :: Name -> ShwiftyM NewtypeInfo
reifyNewtype n = do
DatatypeInfo{..} <- lift $ reifyDatatype n
case (datatypeCons, datatypeVariant) of
([c], Newtype) -> do
pure NewtypeInfo {
newtypeName = datatypeName
, newtypeVars = datatypeVars
, newtypeInstTypes = datatypeInstTypes
, newtypeVariant = datatypeVariant
, newtypeCon = c
}
([c], NewtypeInstance) -> do
pure NewtypeInfo {
newtypeName = datatypeName
, newtypeVars = datatypeVars
, newtypeInstTypes = datatypeInstTypes
, newtypeVariant = datatypeVariant
, newtypeCon = c
}
_ -> do
throwError $ NotANewtype n
getTags :: ()
=> Name
-> [Name]
-> ShwiftyM ([Exp], [Dec])
getTags parentName ts = do
let b = length ts > 1
disambiguate <- lift $ [||b||]
tags <- foldlM
(\(es,ds) n -> do
NewtypeInfo{..} <- reifyNewtype n
let ConstructorInfo{..} = newtypeCon
let tyconName = case newtypeVariant of
NewtypeInstance -> constructorName
_ -> newtypeName
typ <- case constructorFields of
[ty] -> pure ty
_ -> throwError $ NotANewtype newtypeName
let tag = RecConE 'Tag
[ (mkName "tagName", unqualName tyconName)
, (mkName "tagParent", unqualName parentName)
, (mkName "tagTyp", toSwiftEPoly typ)
, (mkName "tagDisambiguate", unType disambiguate)
]
!instHeadTy
<- buildTypeInstance newtypeName ClassSwift newtypeInstTypes newtypeVars newtypeVariant
clauseTy <- tagToSwift tyconName typ parentName
swiftTyInst <- lift $ instanceD
(pure [])
(pure instHeadTy)
[ funD 'toSwift
[ clause [] (normalB (pure clauseTy)) []
]
]
pure $ (es ++ [tag], ds ++ [swiftTyInst])
) ([], []) ts
pure tags
getToSwift :: ()
=> Options
-> Name
-> [Type]
-> [TyVarBndr]
-> DatatypeVariant
-> [ConstructorInfo]
-> ShwiftyM [Dec]
getToSwift Options{..} parentName instTys tyVarBndrs variant cons = if generateToSwift
then do
instHead <- buildTypeInstance parentName ClassSwift instTys tyVarBndrs variant
clauseTy <- case variant of
NewtypeInstance -> case cons of
[ConstructorInfo{..}] -> do
newtypToSwift constructorName instTys
_ -> do
throwError ExpectedNewtypeInstance
_ -> do
typToSwift newtypeTag parentName instTys
inst <- lift $ instanceD
(pure [])
(pure instHead)
[ funD 'toSwift
[ clause [] (normalB (pure clauseTy)) []
]
]
pure [inst]
else do
pure []
getToSwiftData :: ()
=> Options
-> Name
-> [Type]
-> [TyVarBndr]
-> DatatypeVariant
-> [Exp]
-> [ConstructorInfo]
-> ShwiftyM [Dec]
getToSwiftData o@Options{..} parentName instTys tyVarBndrs variant tags cons = if generateToSwiftData
then do
instHead <- buildTypeInstance parentName ClassSwiftData instTys tyVarBndrs variant
clauseData <- consToSwift o parentName instTys variant tags makeBase cons
inst <- lift $ instanceD
(pure [])
(pure instHead)
[ funD 'toSwiftData
[ clause [] (normalB (pure clauseData)) []
]
]
pure [inst]
else do
pure []
getShwiftyWithTags :: ()
=> Options
-> [Name]
-> Name
-> Q [Dec]
getShwiftyWithTags o@Options{..} ts name = do
r <- runExceptT $ do
ensureEnabled ScopedTypeVariables
ensureEnabled DataKinds
DatatypeInfo
{ datatypeName = parentName
, datatypeVars = tyVarBndrs
, datatypeInstTypes = instTys
, datatypeVariant = variant
, datatypeCons = cons
} <- lift $ reifyDatatype name
noExistentials cons
(tags, extraDecs) <- getTags parentName ts
swiftDataInst <- getToSwiftData o parentName instTys tyVarBndrs variant tags cons
swiftTyInst <- getToSwift o parentName instTys tyVarBndrs variant cons
pure $ swiftDataInst ++ swiftTyInst ++ extraDecs
case r of
Left e -> fail $ prettyShwiftyError e
Right d -> pure d
noExistentials :: [ConstructorInfo] -> ShwiftyM ()
noExistentials cs = forM_ cs $ \ConstructorInfo{..} ->
case (constructorName, constructorVars) of
(_, []) -> do
pure ()
(cn, cvs) -> do
throwError $ ExistentialTypes cn cvs
data ShwiftyError
= SingleConNonRecord
{ _conName :: Name
}
| EncounteredInfixConstructor
{ _conName :: Name
}
| KindVariableCannotBeRealised
{ _typName :: Name
, _kind :: Kind
}
| ExtensionNotEnabled
{ _ext :: Extension
}
| ExistentialTypes
{ _conName :: Name
, _types :: [TyVarBndr]
}
| ExpectedNewtypeInstance
| NotANewtype
{ _typName :: Name
}
prettyShwiftyError :: ShwiftyError -> String
prettyShwiftyError = \case
SingleConNonRecord (nameStr -> n) -> mempty
++ n
++ ": Cannot get shwifty with single-constructor "
++ "non-record types. This is due to a "
++ "restriction of Swift that prohibits structs "
++ "from not having named fields. Try turning "
++ n ++ " into a record!"
EncounteredInfixConstructor (nameStr -> n) -> mempty
++ n
++ ": Cannot get shwifty with infix constructors. "
++ "Swift doesn't support them. Try changing "
++ n ++ " into a prefix constructor!"
KindVariableCannotBeRealised (nameStr -> n) typ ->
let (typStr, kindStr) = prettyKindVar typ
in mempty
++ n
++ ": Encountered a type variable ("
++ typStr
++ ") with a kind ("
++ kindStr
++ ") that can't "
++ "get shwifty! Shwifty needs to be able "
++ "to realise your kind variables to `*`, "
++ "since that's all that makes sense in "
++ "Swift. The only kinds that can happen with "
++ "are `*` and the free-est kind, `k`."
ExtensionNotEnabled ext -> mempty
++ show ext
++ " is not enabled. Shwifty needs it to work!"
ExistentialTypes (nameStr -> n) tys -> mempty
++ n
++ " has existential type variables ("
++ L.intercalate ", " (map prettyTyVarBndrStr tys)
++ ")! Shwifty doesn't support these."
ExpectedNewtypeInstance -> mempty
++ "Expected a newtype instance. This is an "
++ "internal logic error. Please report it as a "
++ "bug."
NotANewtype (nameStr -> n) -> mempty
++ n
++ " is not a newtype. This is an internal logic "
++ "error. Please report it as a bug."
prettyTyVarBndrStr :: TyVarBndr -> String
prettyTyVarBndrStr = \case
PlainTV n -> go n
KindedTV n _ -> go n
where
go = TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show
prettyKindVar :: Type -> (String, String)
prettyKindVar = \case
SigT typ k -> (go typ, go k)
VarT n -> (nameStr n, "*")
typ -> error $ "Shwifty.prettyKindVar: used on a type without a kind signature. Type was: " ++ show typ
where
go = TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show . ppr
type ShwiftyM = ExceptT ShwiftyError Q
tagToSwift :: ()
=> Name
-> Type
-> Name
-> ShwiftyM Exp
tagToSwift tyconName typ parentName = do
value <- lift $ newName "value"
ourMatch <- matchProxy
$ tagExp tyconName parentName typ False
let matches = [pure ourMatch]
lift $ lamE [varP value] (caseE (varE value) matches)
newtypToSwift :: ()
=> Name
-> [Type]
-> ShwiftyM Exp
newtypToSwift conName (stripConT -> instTys) = do
typToSwift False conName instTys
typToSwift :: ()
=> Bool
-> Name
-> [Type]
-> ShwiftyM Exp
typToSwift newtypeTag parentName instTys = do
value <- lift $ newName "value"
let tyVars = map toSwiftECxt instTys
let name =
let parentStr = nameStr parentName
accessedName = if newtypeTag
then parentStr ++ "Tag." ++ parentStr
else parentStr
in stringE accessedName
ourMatch <- matchProxy
$ RecConE 'Concrete
$ [ (mkName "concreteName", name)
, (mkName "concreteTyVars", ListE tyVars)
]
let matches = [pure ourMatch]
lift $ lamE [varP value] (caseE (varE value) matches)
rawValueE :: Maybe Ty -> Exp
rawValueE = \case
Nothing -> ConE 'Nothing
Just ty -> AppE (ConE 'Just) (ParensE (tyE ty))
tyE :: Ty -> Exp
tyE = \case
Unit -> ConE 'Unit
Bool -> ConE 'Bool
Character -> ConE 'Character
Str -> ConE 'Str
I -> ConE 'I
I8 -> ConE 'I8
I16 -> ConE 'I16
I32 -> ConE 'I32
I64 -> ConE 'I64
U -> ConE 'U
U8 -> ConE 'U8
U16 -> ConE 'U16
U32 -> ConE 'U32
U64 -> ConE 'U64
F32 -> ConE 'F32
F64 -> ConE 'F64
Decimal -> ConE 'Decimal
BigSInt32 -> ConE 'BigSInt32
BigSInt64 -> ConE 'BigSInt64
Poly s -> AppE (ConE 'Poly) (stringE s)
Concrete tyCon tyVars -> AppE (AppE (ConE 'Concrete) (stringE tyCon)) (ListE (map tyE tyVars))
Tuple2 e1 e2 -> AppE (AppE (ConE 'Tuple2) (tyE e1)) (tyE e2)
Tuple3 e1 e2 e3 -> AppE (AppE (AppE (ConE 'Tuple3) (tyE e1)) (tyE e2)) (tyE e3)
Optional e -> AppE (ConE 'Optional) (tyE e)
Result e1 e2 -> AppE (AppE (ConE 'Result) (tyE e1)) (tyE e2)
Set e -> AppE (ConE 'Set) (tyE e)
Dictionary e1 e2 -> AppE (AppE (ConE 'Dictionary) (tyE e1)) (tyE e2)
App e1 e2 -> AppE (AppE (ConE 'App) (tyE e1)) (tyE e2)
Array e -> AppE (ConE 'Array) (tyE e)
Tag{..} -> AppE (AppE (AppE (AppE (ConE 'Tag) (stringE tagName)) (stringE tagParent)) (tyE tagTyp)) (if tagDisambiguate then ConE 'True else ConE 'False)
consToSwift :: ()
=> Options
-> Name
-> [Type]
-> DatatypeVariant
-> [Exp]
-> (Bool, Maybe Ty, [Protocol])
-> [ConstructorInfo]
-> ShwiftyM Exp
consToSwift o@Options{..} parentName instTys variant ts bs = \case
[] -> do
value <- lift $ newName "value"
matches <- liftCons (mkVoid parentName instTys ts)
lift $ lamE [varP value] (caseE (varE value) matches)
cons -> do
value <- lift $ newName "value"
matches <- matchesWorker
lift $ lamE [varP value] (caseE (varE value) matches)
where
matchesWorker :: ShwiftyM [Q Match]
matchesWorker = case cons of
[con] -> liftCons $ do
case variant of
NewtypeInstance -> do
if | typeAlias -> do
mkNewtypeInstanceAlias instTys con
| otherwise -> do
mkNewtypeInstance o instTys ts con
Newtype -> do
if | newtypeTag -> do
mkTypeTag o parentName instTys con
| typeAlias -> do
mkTypeAlias parentName instTys con
| otherwise -> do
mkProd o parentName instTys ts con
_ -> do
mkProd o parentName instTys ts con
_ -> do
let cons' = flip filter cons $ \ConstructorInfo{..} -> not (nameStr constructorName `elem` omitCases)
cases <- forM cons' (liftEither . mkCase o)
ourMatch <- matchProxy
$ enumExp parentName instTys dataProtocols cases dataRawValue ts bs
pure [pure ourMatch]
liftCons :: (Functor f, Applicative g) => f a -> f ([g a])
liftCons x = ((:[]) . pure) <$> x
mkCaseHelper :: Options -> Name -> [Exp] -> Exp
mkCaseHelper o name es = TupE [ caseName o name, ListE es ]
mkCase :: ()
=> Options
-> ConstructorInfo
-> Either ShwiftyError Exp
mkCase o = \case
ConstructorInfo
{ constructorVariant = NormalConstructor
, constructorName = name
, constructorFields = fields
, ..
} -> Right $ mkCaseHelper o name $ fields <&>
(\typ -> TupE
[ ConE 'Nothing
, toSwiftEPoly typ
]
)
ConstructorInfo
{ constructorVariant = InfixConstructor
, constructorName = name
, ..
} -> Left $ EncounteredInfixConstructor name
ConstructorInfo
{ constructorVariant = RecordConstructor fieldNames
, constructorName = name
, constructorFields = fields
, ..
} ->
let cases = zipWith (caseField o) fieldNames fields
in Right $ mkCaseHelper o name cases
caseField :: Options -> Name -> Type -> Exp
caseField o n typ = TupE
[ mkLabel o n
, toSwiftEPoly typ
]
onHeadWith :: Bool -> String -> String
onHeadWith toLower = if toLower
then onHead Char.toLower
else id
onHead :: (Char -> Char) -> String -> String
onHead f = \case { [] -> []; (x:xs) -> f x : xs }
mkLabel :: Options -> Name -> Exp
mkLabel Options{..} = AppE (ConE 'Just)
. stringE
. fieldLabelModifier
. onHeadWith lowerFirstField
. TS.unpack
. last
. TS.splitOn "."
. TS.pack
. show
mkNewtypeInstanceAlias :: ()
=> [Type]
-> ConstructorInfo
-> ShwiftyM Match
mkNewtypeInstanceAlias (stripConT -> instTys) = \case
ConstructorInfo
{ constructorName = conName
, constructorFields = [field]
, ..
} -> do
lift $ match
(conP 'Proxy [])
(normalB
(pure
(aliasExp conName instTys field)))
[]
_ -> throwError $ ExpectedNewtypeInstance
mkNewtypeInstance :: ()
=> Options
-> [Type]
-> [Exp]
-> ConstructorInfo
-> ShwiftyM Match
mkNewtypeInstance o@Options{..} (stripConT -> instTys) ts = \case
ConstructorInfo
{ constructorVariant = RecordConstructor [fieldName]
, constructorFields = [field]
, ..
} -> do
let fields = [prettyField o fieldName field]
matchProxy $ structExp constructorName instTys dataProtocols fields ts makeBase
_ -> throwError ExpectedNewtypeInstance
mkTypeTag :: ()
=> Options
-> Name
-> [Type]
-> ConstructorInfo
-> ShwiftyM Match
mkTypeTag Options{..} typName instTys = \case
ConstructorInfo
{ constructorFields = [field]
, ..
} -> do
let parentName = mkName
(nameStr typName ++ "Tag")
let tag = tagExp typName parentName field False
matchProxy $ enumExp parentName instTys dataProtocols [] dataRawValue [tag] (False, Nothing, [])
_ -> throwError $ NotANewtype typName
mkTypeAlias :: ()
=> Name
-> [Type]
-> ConstructorInfo
-> ShwiftyM Match
mkTypeAlias typName instTys = \case
ConstructorInfo
{ constructorFields = [field]
, ..
} -> do
lift $ match
(conP 'Proxy [])
(normalB
(pure (aliasExp typName instTys field)))
[]
_ -> throwError $ NotANewtype typName
mkVoid :: ()
=> Name
-> [Type]
-> [Exp]
-> ShwiftyM Match
mkVoid typName instTys ts = matchProxy
$ enumExp typName instTys [] [] Nothing ts (False, Nothing, [])
mkProd :: ()
=> Options
-> Name
-> [Type]
-> [Exp]
-> ConstructorInfo
-> ShwiftyM Match
mkProd o@Options{..} typName instTys ts = \case
ConstructorInfo
{ constructorVariant = NormalConstructor
, constructorFields = []
, ..
} -> do
matchProxy $ structExp typName instTys dataProtocols [] ts makeBase
ConstructorInfo
{ constructorVariant = NormalConstructor
, constructorName = name
} -> do
throwError $ SingleConNonRecord name
ConstructorInfo
{ constructorVariant = InfixConstructor
, constructorName = name
} -> do
throwError $ EncounteredInfixConstructor name
ConstructorInfo
{ constructorVariant = RecordConstructor fieldNames
, ..
} -> do
let fields = zipFields o fieldNames constructorFields
matchProxy $ structExp typName instTys dataProtocols fields ts makeBase
zipFields :: Options -> [Name] -> [Type] -> [Exp]
zipFields o = zipWithPred p (prettyField o)
where
p :: Name -> Type -> Bool
p n _ = not $ nameStr n `elem` omitFields o
zipWithPred :: (a -> b -> Bool) -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithPred _ _ [] _ = []
zipWithPred _ _ _ [] = []
zipWithPred p f (x:xs) (y:ys)
| p x y = f x y : zipWithPred p f xs ys
| otherwise = zipWithPred p f xs ys
caseName :: Options -> Name -> Exp
caseName Options{..} = id
. stringE
. onHeadWith lowerFirstCase
. constructorModifier
. TS.unpack
. last
. TS.splitOn "."
. TS.pack
. show
nameStr :: Name -> String
nameStr = TS.unpack . last . TS.splitOn "." . TS.pack . show
unqualName :: Name -> Exp
unqualName = stringE . nameStr
prettyTyVar :: Name -> Exp
prettyTyVar = stringE . map Char.toUpper . TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show
prettyTyVars :: [Type] -> Exp
prettyTyVars = ListE . map prettyTyVar . getTyVars
getTyVars :: [Type] -> [Name]
getTyVars = mapMaybe getFreeTyVar
getFreeTyVar :: Type -> Maybe Name
getFreeTyVar = \case
VarT name -> Just name
SigT (VarT name) _kind -> Just name
_ -> Nothing
prettyField :: Options -> Name -> Type -> Exp
prettyField Options{..} name ty = TupE
[ (stringE (onHeadWith lowerFirstField (fieldLabelModifier (nameStr name))))
, toSwiftEPoly ty
]
buildTypeInstance :: ()
=> Name
-> ShwiftyClass
-> [Type]
-> [TyVarBndr]
-> DatatypeVariant
-> ShwiftyM Type
buildTypeInstance tyConName cls varTysOrig tyVarBndrs variant = do
varTysExp <- lift $ mapM resolveTypeSynonyms varTysOrig
starKindStats :: [KindStatus] <- foldlM
(\stats k -> case canRealiseKindStar k of
NotKindStar -> do
throwError $ KindVariableCannotBeRealised tyConName k
s -> pure (stats ++ [s])
) [] varTysExp
let
kindVarNames :: [Name]
kindVarNames = flip mapMaybe starKindStats
(\case
IsKindVar n -> Just n
_ -> Nothing
)
let
varTysExpSubst :: [Type]
varTysExpSubst = map (substNamesWithKindStar kindVarNames) varTysExp
preds :: [Maybe Pred]
preds = map (deriveConstraint cls) varTysExpSubst
varTysOrigSubst :: [Type]
varTysOrigSubst =
map (substNamesWithKindStar kindVarNames) $ varTysOrig
varTysOrigSubst' :: [Type]
varTysOrigSubst' = if isDataFamily variant
then varTysOrigSubst
else map unSigT varTysOrigSubst
instanceCxt :: Cxt
instanceCxt = catMaybes preds
instanceType :: Type
instanceType = AppT (ConT (shwiftyClassName cls))
$ applyTyCon tyConName varTysOrigSubst'
lift $ forallT
(map tyVarBndrNoSig tyVarBndrs)
(pure instanceCxt)
(pure instanceType)
data ShwiftyClass
= ClassSwift
| ClassSwiftData
shwiftyClassName :: ShwiftyClass -> Name
shwiftyClassName = \case
ClassSwift -> ''ToSwift
ClassSwiftData -> ''ToSwiftData
deriveConstraint :: ()
=> ShwiftyClass
-> Type
-> Maybe Pred
deriveConstraint c@ClassSwift typ
| not (isTyVar typ) = Nothing
| hasKindStar typ = Just (applyCon (shwiftyClassName c) tName)
| otherwise = Nothing
where
tName :: Name
tName = varTToName typ
varTToName = \case
VarT n -> n
SigT t _ -> varTToName t
_ -> error "Shwifty.varTToName: encountered non-type variable"
deriveConstraint ClassSwiftData _ = Nothing
applyCon :: Name -> Name -> Pred
applyCon con t = AppT (ConT con) (VarT t)
unSigT :: Type -> Type
unSigT = \case
SigT t _ -> t
t -> t
isTyVar :: Type -> Bool
isTyVar = \case
VarT _ -> True
SigT t _ -> isTyVar t
_ -> False
hasKindStar :: Type -> Bool
hasKindStar = \case
VarT _ -> True
SigT _ StarT -> True
_ -> False
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns
where
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind n k = applySubstitution (M.singleton n k)
data KindStatus
= KindStar
| NotKindStar
| IsKindVar Name
| IsCon Name
canRealiseKindStar :: Type -> KindStatus
canRealiseKindStar = \case
VarT{} -> KindStar
SigT _ StarT -> KindStar
SigT _ (VarT n) -> IsKindVar n
ConT n -> IsCon n
_ -> NotKindStar
tyVarBndrNoSig :: TyVarBndr -> TyVarBndr
tyVarBndrNoSig = \case
PlainTV n -> PlainTV n
KindedTV n _k -> PlainTV n
applyTyCon :: Name -> [Type] -> Type
applyTyCon = foldl' AppT . ConT
stringE :: String -> Exp
stringE = LitE . StringL
toSwiftECxt :: Type -> Exp
toSwiftECxt (unSigT -> typ) = AppE
(VarE 'toSwift)
(SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ))
toSwiftEPoly :: Type -> Exp
toSwiftEPoly = \case
VarT n
-> AppE (ConE 'Poly) (prettyTyVar n)
SigT (VarT n) _
-> AppE (ConE 'Poly) (prettyTyVar n)
typ ->
let decompressed = decompress typ
prettyName = map Char.toUpper . TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show
filledInHoles = decompressed <&>
(\case
VarT name -> AppT
(ConT ''Shwifty.SingSymbol)
(LitT (StrTyLit (prettyName name)))
SigT (VarT name) _ -> AppT
(ConT ''Shwifty.SingSymbol)
(LitT (StrTyLit (prettyName name)))
t -> t
)
typ' = compress filledInHoles
in AppE
(VarE 'toSwift)
(SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ'))
decompress :: Type -> Rose Type
decompress typ = case unapplyTy typ of
tyCon :| tyArgs -> Rose tyCon (decompress <$> tyArgs)
compress :: Rose Type -> Type
compress (Rose typ []) = typ
compress (Rose t ts) = foldl' AppT t (compress <$> ts)
unapplyTy :: Type -> NonEmpty Type
unapplyTy = NE.reverse . go
where
go = \case
AppT t1 t2 -> t2 <| go t1
SigT t _ -> go t
ForallT _ _ t -> go t
t -> t :| []
data Rose a = Rose a [Rose a]
deriving stock (Eq, Show)
deriving stock (Functor,Foldable,Traversable)
isDataFamily :: DatatypeVariant -> Bool
isDataFamily = \case
NewtypeInstance -> True
DataInstance -> True
_ -> False
stripConT :: [Type] -> [Type]
stripConT = mapMaybe noConT
where
noConT = \case
ConT {} -> Nothing
t -> Just t
getShwiftyCodec :: forall tag. ModifyOptions tag => Codec tag -> Name -> Q [Dec]
getShwiftyCodec c = getShwiftyCodecTags c []
getShwiftyCodecTags :: forall tag. ModifyOptions tag => Codec tag -> [Name] -> Name -> Q [Dec]
getShwiftyCodecTags _ ts n = getShwiftyWithTags (modifyOptions @tag defaultOptions) ts n
aliasExp :: ()
=> Name
-> [Type]
-> Type
-> Exp
aliasExp name tyVars field = RecConE 'SwiftAlias
[ (mkName "aliasName", unqualName name)
, (mkName "aliasTyVars", prettyTyVars tyVars)
, (mkName "aliasTyp", toSwiftECxt field)
]
tagExp :: ()
=> Name
-> Name
-> Type
-> Bool
-> Exp
tagExp tyconName parentName typ dis = RecConE 'Tag
[ (mkName "tagName", unqualName tyconName)
, (mkName "tagParent", unqualName parentName)
, (mkName "tagTyp", toSwiftECxt typ)
, (mkName "tagDisambiguate", case dis of
{ False -> ConE 'False
; True -> ConE 'True
})
]
enumExp :: ()
=> Name
-> [Type]
-> [Protocol]
-> [Exp]
-> Maybe Ty
-> [Exp]
-> (Bool, Maybe Ty, [Protocol])
-> Exp
enumExp parentName tyVars protos cases raw tags bs
= applyBase bs $ RecConE 'SwiftEnum
[ (mkName "enumName", unqualName parentName)
, (mkName "enumTyVars", prettyTyVars tyVars)
, (mkName "enumProtocols", protosExp protos)
, (mkName "enumCases", ListE cases)
, (mkName "enumRawValue", rawValueE raw)
, (mkName "enumPrivateTypes", ListE [])
, (mkName "enumTags", ListE tags)
]
structExp :: ()
=> Name
-> [Type]
-> [Protocol]
-> [Exp]
-> [Exp]
-> (Bool, Maybe Ty, [Protocol])
-> Exp
structExp name tyVars protos fields tags bs
= applyBase bs $ RecConE 'SwiftStruct
[ (mkName "structName", unqualName name)
, (mkName "structTyVars", prettyTyVars tyVars)
, (mkName "structProtocols", protosExp protos)
, (mkName "structFields", ListE fields)
, (mkName "structPrivateTypes", ListE [])
, (mkName "structTags", ListE tags)
]
matchProxy :: Exp -> ShwiftyM Match
matchProxy e = lift $ match
(conP 'Proxy [])
(normalB (pure e))
[]
stripFields :: SwiftData -> SwiftData
stripFields = \case
s@SwiftStruct{} -> s { structFields = [] }
s@SwiftEnum{} -> s { enumCases = go (enumCases s) }
where
go = map stripOne
stripOne (x, _) = (x, [])
s -> s
giveProtos :: [Protocol] -> SwiftData -> SwiftData
giveProtos ps = \case
s@SwiftStruct{} -> s { structProtocols = ps }
s@SwiftEnum{} -> s { enumProtocols = ps }
s -> s
suffixBase :: SwiftData -> SwiftData
suffixBase = \case
s@SwiftStruct{} -> s { structName = structName s ++ "Base" }
s@SwiftEnum{} -> s { enumName = enumName s ++ "Base" }
s -> s
giveBase :: Maybe Ty -> [Protocol] -> SwiftData -> SwiftData
giveBase r ps = \case
s@SwiftStruct{} -> s { structPrivateTypes = [giveProtos ps (suffixBase (stripFields s))] }
s@SwiftEnum{} -> s { enumPrivateTypes = [ giveProtos ps (suffixBase (stripFields s)) { enumRawValue = r }] }
s -> s
applyBase :: (Bool, Maybe Ty, [Protocol]) -> Exp -> Exp
applyBase (b, r, ps) (ParensE -> s) = if b
then
AppE (AppE (AppE (VarE 'giveBase) (rawValueE r)) (protosExp ps)) s
else s
protosExp :: [Protocol] -> Exp
protosExp = ListE . map (ConE . mkName . show)