{-# language
AllowAmbiguousTypes
, BangPatterns
, CPP
, DataKinds
, DefaultSignatures
, DeriveFoldable
, DeriveFunctor
, DeriveGeneric
, DeriveLift
, DeriveTraversable
, DerivingStrategies
, DuplicateRecordFields
, FlexibleInstances
, GADTs
, KindSignatures
, LambdaCase
, MultiWayIf
, NamedFieldPuns
, OverloadedStrings
, PolyKinds
, RecordWildCards
, ScopedTypeVariables
, TemplateHaskell
, TypeApplications
, ViewPatterns
#-}
{-# options_ghc
-Wall
-fno-warn-duplicate-exports
#-}
module Shwifty
(
ToSwift(..)
, ToSwiftData(..)
, getShwifty
, getShwiftyWith
, getShwiftyWithTags
, Ty(..)
, SwiftData(..)
, Protocol(..)
, Options
, fieldLabelModifier
, constructorModifier
, optionalExpand
, indent
, generateToSwift
, generateToSwiftData
, dataProtocols
, dataRawValue
, typeAlias
, newtypeTag
, lowerFirstCase
, lowerFirstField
, defaultOptions
, prettyTy
, prettySwiftData
, X
) where
#include "MachDeps.h"
import Control.Monad.Except
import Data.CaseInsensitive (CI)
import Data.Foldable (foldlM,foldr',foldl')
import Data.Functor ((<&>))
import Data.Int (Int8,Int16,Int32,Int64)
import Data.List (intercalate)
import Data.List.NonEmpty ((<|), NonEmpty(..))
import Data.Maybe (mapMaybe, catMaybes)
import Data.Proxy (Proxy(..))
import Data.Time (UTCTime)
import Data.UUID.Types (UUID)
import Data.Vector (Vector)
import Data.Void (Void)
import Data.Word (Word8,Word16,Word32,Word64)
import GHC.Generics (Generic)
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Language.Haskell.TH hiding (stringE)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Syntax (Lift)
import Prelude hiding (Enum(..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as HM
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 qualified Data.Text.Lazy as TL
import qualified Data.Primitive as Prim
data Ty
= Unit
| Bool
| Character
| Str
| I
| I8
| I16
| I32
| I64
| U
| U8
| U16
| U32
| U64
| F32
| F64
| Decimal
| BigSInt32
| BigSInt64
| Tuple2 Ty Ty
| Tuple3 Ty Ty Ty
| Optional Ty
| Result Ty Ty
| Set Ty
| Dictionary Ty Ty
| Array Ty
| App Ty Ty
| Poly String
| Concrete
{ name :: String
, tyVars :: [Ty]
}
| Tag
{ name :: String
, parent :: String
, typ :: Ty
, disambiguate :: Bool
}
deriving stock (Eq, Show, Read)
deriving stock (Generic)
deriving stock (Lift)
data SwiftData
= SwiftStruct
{ name :: String
, tyVars :: [String]
, protocols :: [Protocol]
, fields :: [(String, Ty)]
, tags :: [Ty]
}
| SwiftEnum
{ name :: String
, tyVars :: [String]
, protocols :: [Protocol]
, cases :: [(String, [(Maybe String, Ty)])]
, rawValue :: Maybe Ty
, tags :: [Ty]
}
| TypeAlias
{ name :: String
, tyVars :: [String]
, typ :: Ty
}
deriving stock (Eq, Read, Show, Generic)
class ToSwiftData a where
toSwiftData :: Proxy a -> SwiftData
prettySwiftData :: Proxy a -> String
default prettySwiftData :: Proxy a -> String
prettySwiftData = prettySwiftDataWith (indent defaultOptions) . toSwiftData
data Protocol
= Hashable
| Codable
| Equatable
deriving stock (Eq, Read, Show, Generic)
deriving stock (Lift)
data Options = Options
{ typeConstructorModifier :: String -> String
, fieldLabelModifier :: String -> String
, constructorModifier :: String -> String
, optionalExpand :: Bool
, indent :: Int
, generateToSwift :: Bool
, generateToSwiftData :: Bool
, dataProtocols :: [Protocol]
, dataRawValue :: Maybe Ty
, typeAlias :: Bool
, newtypeTag :: Bool
, lowerFirstField :: Bool
, lowerFirstCase :: Bool
}
defaultOptions :: Options
defaultOptions = Options
{ typeConstructorModifier = id
, fieldLabelModifier = id
, constructorModifier = id
, optionalExpand = False
, indent = 4
, generateToSwift = True
, generateToSwiftData = True
, dataProtocols = []
, dataRawValue = Nothing
, typeAlias = False
, newtypeTag = False
, lowerFirstField = True
, lowerFirstCase = True
}
class ToSwift a where
toSwift :: Proxy a -> Ty
data SingSymbol (x :: Symbol)
instance KnownSymbol x => ToSwift (SingSymbol x) where
toSwift _ = Poly (symbolVal (Proxy @x))
type X = Void
instance ToSwift Void where
toSwift = const (Concrete "Void" [])
instance ToSwift () where
toSwift = const Unit
instance ToSwift Bool where
toSwift = const Bool
instance ToSwift UUID where
toSwift = const (Concrete "UUID" [])
instance ToSwift UTCTime where
toSwift = const (Concrete "Date" [])
instance forall a b. (ToSwift a, ToSwift b) => ToSwift (a -> b) where
toSwift = const (App (toSwift (Proxy @a)) (toSwift (Proxy @b)))
instance forall a. ToSwift a => ToSwift (Maybe a) where
toSwift = const (Optional (toSwift (Proxy @a)))
instance forall a b. (ToSwift a, ToSwift b) => ToSwift (Either a b) where
toSwift = const (Result (toSwift (Proxy @b)) (toSwift (Proxy @a)))
instance ToSwift Integer where
toSwift = const
#if WORD_SIZE_IN_BITS == 32
BigSInt32
#else
BigSInt64
#endif
instance ToSwift Int where toSwift = const I
instance ToSwift Int8 where toSwift = const I8
instance ToSwift Int16 where toSwift = const I16
instance ToSwift Int32 where toSwift = const I32
instance ToSwift Int64 where toSwift = const I64
instance ToSwift Word where toSwift = const U
instance ToSwift Word8 where toSwift = const U8
instance ToSwift Word16 where toSwift = const U16
instance ToSwift Word32 where toSwift = const U32
instance ToSwift Word64 where toSwift = const U64
instance ToSwift Float where toSwift = const F32
instance ToSwift Double where toSwift = const F64
instance ToSwift Char where toSwift = const Character
instance forall a. (ToSwift a) => ToSwift (Prim.Array a) where
toSwift = const (Array (toSwift (Proxy @a)))
instance forall a. (ToSwift a) => ToSwift (Prim.SmallArray a) where
toSwift = const (Array (toSwift (Proxy @a)))
instance ToSwift Prim.ByteArray where
toSwift = const (Array U8)
instance forall a. (ToSwift a) => ToSwift (Prim.PrimArray a) where
toSwift = const (Array (toSwift (Proxy @a)))
instance forall a. ToSwift a => ToSwift (Vector a) where
toSwift = const (Array (toSwift (Proxy @a)))
instance {-# overlappable #-} forall a. ToSwift a => ToSwift [a] where
toSwift = const (Array (toSwift (Proxy @a)))
instance {-# overlapping #-} ToSwift [Char] where toSwift = const Str
instance ToSwift TL.Text where toSwift = const Str
instance ToSwift TS.Text where toSwift = const Str
instance ToSwift BL.ByteString where toSwift = const (Array U8)
instance ToSwift BS.ByteString where toSwift = const (Array U8)
instance ToSwift (CI s) where toSwift = const Str
instance forall k v. (ToSwift k, ToSwift v) => ToSwift (M.Map k v) where toSwift = const (Dictionary (toSwift (Proxy @k)) (toSwift (Proxy @v)))
instance forall k v. (ToSwift k, ToSwift v) => ToSwift (HM.HashMap k v) where toSwift = const (Dictionary (toSwift (Proxy @k)) (toSwift (Proxy @v)))
instance forall a b. (ToSwift a, ToSwift b) => ToSwift ((,) a b) where
toSwift = const (Tuple2 (toSwift (Proxy @a)) (toSwift (Proxy @b)))
instance forall a b c. (ToSwift a, ToSwift b, ToSwift c) => ToSwift ((,,) a b c) where
toSwift = const (Tuple3 (toSwift (Proxy @a)) (toSwift (Proxy @b)) (toSwift (Proxy @c)))
labelCase :: Maybe String -> Ty -> String
labelCase Nothing ty = prettyTy ty
labelCase (Just label) ty = "_ " ++ label ++ ": " ++ prettyTy ty
prettyTypeHeader :: String -> [String] -> String
prettyTypeHeader name [] = name
prettyTypeHeader name tyVars = name ++ "<" ++ intercalate ", " tyVars ++ ">"
prettyTy :: Ty -> String
prettyTy = \case
Str -> "String"
Unit -> "()"
Bool -> "Bool"
Character -> "Character"
Tuple2 e1 e2 -> "(" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ")"
Tuple3 e1 e2 e3 -> "(" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ", " ++ prettyTy e3 ++ ")"
Optional e -> prettyTy e ++ "?"
Result e1 e2 -> "Result<" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ">"
Set e -> "Set<" ++ prettyTy e ++ ">"
Dictionary e1 e2 -> "Dictionary<" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ">"
Array e -> "[" ++ prettyTy e ++ "]"
App e1 e2 -> prettyApp e1 e2
I -> "Int"
I8 -> "Int8"
I16 -> "Int16"
I32 -> "Int32"
I64 -> "Int64"
U -> "UInt"
U8 -> "UInt8"
U16 -> "UInt16"
U32 -> "UInt32"
U64 -> "UInt64"
F32 -> "Float"
F64 -> "Double"
Decimal -> "Decimal"
BigSInt32 -> "BigSInt32"
BigSInt64 -> "BigSInt64"
Poly ty -> ty
Concrete ty [] -> ty
Concrete ty tys -> ty
++ "<"
++ intercalate ", " (map prettyTy tys)
++ ">"
Tag {name,parent} -> parent ++ "." ++ name
prettyApp :: Ty -> Ty -> String
prettyApp t1 t2 = "(("
++ intercalate ", " (map prettyTy as)
++ ") -> "
++ prettyTy r
++ ")"
where
(as, r) = go t1 t2
go e1 (App e2 e3) = case go e2 e3 of
(args, ret) -> (e1 : args, ret)
go e1 e2 = ([e1], e2)
prettyRawValueAndProtocols :: Maybe Ty -> [Protocol] -> String
prettyRawValueAndProtocols Nothing ps = prettyProtocols ps
prettyRawValueAndProtocols (Just ty) [] = ": " ++ prettyTy ty
prettyRawValueAndProtocols (Just ty) ps = ": " ++ prettyTy ty ++ ", " ++ intercalate ", " (map show ps)
prettyProtocols :: [Protocol] -> String
prettyProtocols = \case
[] -> ""
ps -> ": " ++ intercalate ", " (map show ps)
prettyTags :: String -> [Ty] -> String
prettyTags indents = go where
go [] = ""
go (Tag{name,parent,typ,disambiguate}:ts) = []
++ "\n"
++ prettyTagDisambiguator disambiguate indents name
++ indents
++ "typealias "
++ name
++ " = Tagged<"
++ (if disambiguate then name ++ "Tag" else parent)
++ ", "
++ prettyTy typ
++ ">"
++ go ts
go _ = error "non-tag supplied to prettyTags"
prettyTagDisambiguator :: ()
=> Bool
-> String
-> String
-> String
prettyTagDisambiguator disambiguate indents parent
= if disambiguate
then []
++ indents
++ "enum "
++ parent
++ "Tag { }\n"
else ""
prettySwiftDataWith :: ()
=> Int
-> SwiftData
-> String
prettySwiftDataWith indent = \case
SwiftEnum {name,tyVars,protocols,cases,rawValue,tags} -> []
++ "enum "
++ prettyTypeHeader name tyVars
++ prettyRawValueAndProtocols rawValue protocols
++ " {"
++ newlineNonEmpty cases
++ go cases
++ prettyTags indents tags
++ newlineNonEmpty tags
++ "}"
where
go [] = ""
go ((caseNm, []):xs) = []
++ indents
++ "case "
++ caseNm
++ "\n"
++ go xs
go ((caseNm, cs):xs) = []
++ indents
++ "case "
++ caseNm
++ "("
++ (intercalate ", " (map (uncurry labelCase) cs))
++ ")\n"
++ go xs
SwiftStruct {name,tyVars,protocols,fields,tags} -> []
++ "struct "
++ prettyTypeHeader name tyVars
++ prettyProtocols protocols
++ " {"
++ newlineNonEmpty fields
++ go fields
++ prettyTags indents tags
++ newlineNonEmpty tags
++ "}"
where
go [] = ""
go ((fieldName,ty):fs) = indents ++ "let " ++ fieldName ++ ": " ++ prettyTy ty ++ "\n" ++ go fs
TypeAlias {name, tyVars, typ} -> []
++ "typealias "
++ prettyTypeHeader name tyVars
++ " = "
++ prettyTy typ
where
indents = replicate indent ' '
newlineNonEmpty [] = ""
newlineNonEmpty _ = "\n"
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 of
[c] -> 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 len = length ts
disambiguate <- lift $ [||len > 1||]
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 "name", unqualName tyconName)
, (mkName "parent", unqualName parentName)
, (mkName "typ", toSwiftEPoly typ)
, (mkName "disambiguate", 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 cons
clausePretty <- mkClausePretty o
inst <- lift $ instanceD
(pure [])
(pure instHead)
[ funD 'toSwiftData
[ clause [] (normalB (pure clauseData)) []
]
, funD 'prettySwiftData
[ clause [] (normalB (pure clausePretty)) []
]
]
pure [inst]
else do
pure []
getShwiftyWithTags :: ()
=> Options
-> [Name]
-> Name
-> Q [Dec]
getShwiftyWithTags o@Options{..} ts name = do
r <- runExceptT $ do
ensureEnabled ScopedTypeVariables
ensureEnabled DataKinds
ensureEnabled DuplicateRecordFields
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"
matches <- lift $ fmap ((:[]) . pure) $ do
match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'Tag
$ [ (mkName "name", unqualName tyconName)
, (mkName "parent", unqualName parentName)
, (mkName "typ", toSwiftECxt typ)
, (mkName "disambiguate", (ConE 'False))
]
)
[]
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
matches <- lift $ fmap ((:[]) . pure) $ do
match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'Concrete
$ [ (mkName "name", name)
, (mkName "tyVars", ListE tyVars)
]
)
[]
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{name,parent,typ,disambiguate} -> AppE (AppE (AppE (AppE (ConE 'Tag) (stringE name)) (stringE parent)) (tyE typ)) (if disambiguate then ConE 'True else ConE 'False)
mkClausePretty :: ()
=> Options
-> ShwiftyM Exp
mkClausePretty Options{..} = do
value <- lift $ newName "value"
matches <- lift $ do
x <- match
(conP 'Proxy [])
(normalB
$ pure
$ AppE
(AppE
(VarE 'prettySwiftDataWith)
(LitE (IntegerL (fromIntegral indent)))
)
$ ParensE
(AppE
(VarE 'toSwiftData)
(VarE value)
)
)
[]
pure [pure x]
lift $ lamE [varP value] (caseE (varE value) matches)
consToSwift :: ()
=> Options
-> Name
-> [Type]
-> DatatypeVariant
-> [Exp]
-> [ConstructorInfo]
-> ShwiftyM Exp
consToSwift o@Options{..} parentName instTys variant ts = \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 tyVars = prettyTyVars instTys
let protos = map (ConE . mkName . show) dataProtocols
let raw = rawValueE dataRawValue
let tags = ListE ts
cases <- forM cons (liftEither . mkCase o)
pure $ (:[]) $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'SwiftEnum
$ [ (mkName "name", unqualName parentName)
, (mkName "tyVars", tyVars)
, (mkName "protocols", ListE protos)
, (mkName "cases", ListE cases)
, (mkName "rawValue", raw)
, (mkName "tags", tags)
]
)
[]
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
{ constructorFields = [field]
, ..
} -> do
let tyVars = prettyTyVars instTys
lift $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'TypeAlias
$ [ (mkName "name", unqualName constructorName)
, (mkName "tyVars", tyVars)
, (mkName "typ", toSwiftECxt field)
]
)
[]
_ -> throwError $ ExpectedNewtypeInstance
mkNewtypeInstance :: ()
=> Options
-> [Type]
-> [Exp]
-> ConstructorInfo
-> ShwiftyM Match
mkNewtypeInstance o@Options{dataProtocols} (stripConT -> instTys) ts = \case
ConstructorInfo
{ constructorVariant = RecordConstructor [fieldName]
, constructorFields = [field]
, ..
} -> do
let tyVars = prettyTyVars instTys
let protos = ListE $ map (ConE . mkName . show) dataProtocols
let fields = ListE $ [prettyField o fieldName field]
let tags = ListE ts
lift $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'SwiftStruct
$ [ (mkName "name", unqualName constructorName)
, (mkName "tyVars", tyVars)
, (mkName "protocols", protos)
, (mkName "fields", fields)
, (mkName "tags", tags)
]
)
[]
_ -> throwError ExpectedNewtypeInstance
mkTypeTag :: ()
=> Options
-> Name
-> [Type]
-> ConstructorInfo
-> ShwiftyM Match
mkTypeTag Options{..} typName instTys = \case
ConstructorInfo
{ constructorFields = [field]
, ..
} -> do
let tyVars = prettyTyVars instTys
let protos = map (ConE . mkName . show) dataProtocols
let raw = rawValueE dataRawValue
let parentName = nameStr typName ++ "Tag"
let tag = RecConE 'Tag
[ (mkName "name", unqualName typName)
, (mkName "parent", stringE parentName)
, (mkName "typ", toSwiftEPoly field)
, (mkName "disambiguate", ConE 'False)
]
lift $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'SwiftEnum
$ [ (mkName "name", stringE parentName)
, (mkName "tyVars", tyVars)
, (mkName "protocols", ListE protos)
, (mkName "cases", ListE [])
, (mkName "rawValue", raw)
, (mkName "tags", ListE [tag])
]
)
[]
_ -> throwError $ NotANewtype typName
mkTypeAlias :: ()
=> Name
-> [Type]
-> ConstructorInfo
-> ShwiftyM Match
mkTypeAlias typName instTys = \case
ConstructorInfo
{ constructorFields = [field]
, ..
} -> do
let tyVars = prettyTyVars instTys
lift $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'TypeAlias
$ [ (mkName "name", unqualName typName)
, (mkName "tyVars", tyVars)
, (mkName "typ", toSwiftECxt field)
]
)
[]
_ -> throwError $ NotANewtype typName
mkVoid :: ()
=> Name
-> [Type]
-> [Exp]
-> ShwiftyM Match
mkVoid typName instTys ts = do
let tyVars = prettyTyVars instTys
lift $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'SwiftEnum
$ [ (mkName "name", unqualName typName)
, (mkName "tyVars", tyVars)
, (mkName "protocols", ListE [])
, (mkName "cases", ListE [])
, (mkName "rawValue", ConE 'Nothing)
, (mkName "tags", ListE ts)
]
)
[]
mkProd :: ()
=> Options
-> Name
-> [Type]
-> [Exp]
-> ConstructorInfo
-> ShwiftyM Match
mkProd o@Options{dataProtocols} typName instTys ts = \case
ConstructorInfo
{ constructorVariant = NormalConstructor
, constructorFields = []
, ..
} -> do
let tyVars = prettyTyVars instTys
let protos = map (ConE . mkName . show) dataProtocols
let tags = ListE ts
lift $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'SwiftStruct
$ [ (mkName "name", unqualName typName)
, (mkName "tyVars", tyVars)
, (mkName "protocols", ListE protos)
, (mkName "fields", ListE [])
, (mkName "tags", tags)
]
)
[]
ConstructorInfo
{ constructorVariant = NormalConstructor
, constructorName = name
} -> do
throwError $ SingleConNonRecord name
ConstructorInfo
{ constructorVariant = InfixConstructor
, constructorName = name
} -> do
throwError $ EncounteredInfixConstructor name
ConstructorInfo
{ constructorVariant = RecordConstructor fieldNames
, ..
} -> do
let tyVars = prettyTyVars instTys
let protos = map (ConE . mkName . show) dataProtocols
let fields = ListE $ zipWith (prettyField o) fieldNames constructorFields
let tags = ListE ts
lift $ match
(conP 'Proxy [])
(normalB
$ pure
$ RecConE 'SwiftStruct
$ [ (mkName "name", unqualName typName)
, (mkName "tyVars", tyVars)
, (mkName "protocols", ListE protos)
, (mkName "fields", fields)
, (mkName "tags", tags)
]
)
[]
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