├── CHANGELOG.md ├── LICENSE ├── shwifty.cabal ├── README.md └── src ├── Shwifty ├── Class.hs ├── Pretty.hs ├── Codec.hs └── Types.hs ├── Test.hs └── Shwifty.hs /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for shwifty 2 | 3 | ## TBD 4 | 5 | * Add 'OtherProtocol' protocol constructor 6 | 7 | ## 0.0.2.0 - 2020-02-26 8 | 9 | * Primitive lower bound: 0.7 -> 0.6.4 10 | * Fix issue with type defaulting in disambiguate 11 | * Add docs to 'toSwift' 12 | * Add 'Codec' API for cleaner deriving 13 | * Remove usage of -XDuplicateRecordFields 14 | * Add getShwiftyCodecTags 15 | * Cleanup internal code (organise but maintain external API) 16 | * Add support for private enums/structs 17 | * Add support for 'base' types 18 | * Add support for omitting fields and cases 19 | * Remove indent option 20 | * Fix pretty-printing for functions in swift 21 | * Remove instance for Void 22 | * Make 'prettySwiftData' a top-level function 23 | * Remove 'Comparable' protocol 24 | 25 | ## 0.0.1.0 -- 2020-02-03 26 | 27 | * First version. Released on an unsuspecting world. 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 chessai 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /shwifty.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | shwifty 4 | version: 5 | 0.0.3.0 6 | synopsis: 7 | Generate swift types from haskell types. 8 | description: 9 | Shwifty provides many utilities for generating swift types from haskell types, 10 | with great flexibility in representation, and emphasis on generating typesafe 11 | Swift code. Most of the types representable in Haskell98 are supported. 12 | bug-reports: 13 | https://github.com/chessai/shwifty/issues 14 | license: 15 | MIT 16 | license-file: 17 | LICENSE 18 | author: 19 | chessai 20 | maintainer: 21 | chessai 22 | copyright: 23 | Copyright (c) 2020, chessai 24 | category: 25 | Codegen, Text, TemplateHaskell 26 | build-type: 27 | Simple 28 | extra-source-files: 29 | CHANGELOG.md 30 | README.md 31 | 32 | library 33 | hs-source-dirs: 34 | src 35 | exposed-modules: 36 | Shwifty 37 | --Test 38 | other-modules: 39 | Shwifty.Class 40 | Shwifty.Codec 41 | Shwifty.Pretty 42 | Shwifty.Types 43 | build-depends: 44 | , aeson >= 1.0 && < 2 45 | , base >= 4.11 && < 4.15 46 | , bytestring >= 0.10 && < 0.11 47 | , case-insensitive >= 1.2 && < 1.3 48 | , containers >= 0.5.9 && < 0.7 49 | , mtl >= 2.2 && < 2.3 50 | , primitive >= 0.6.4 && < 0.8 51 | , scientific >= 0.3.6 && < 0.4 52 | , template-haskell >= 2.11 && < 2.17 53 | , text >= 1.2 && < 1.3 54 | , th-abstraction >= 0.3 && < 0.5 55 | , time >= 1.8 && < 1.11 56 | , unordered-containers >= 0.2 && < 0.3 57 | , uuid-types >= 1.0 && < 1.1 58 | , vector >= 0.12 && < 0.13 59 | default-language: 60 | Haskell2010 61 | 62 | source-repository head 63 | type: 64 | git 65 | location: 66 | git://github.com/chessai/shwifty.git 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Shwifty 2 | 3 | ## Generate Swift types from Haskell types 4 | 5 | Examples: 6 | 7 | #### A simple sum type 8 | ```haskell 9 | data SumType = Sum1 | Sum2 | Sum3 10 | getShwifty ''SumType 11 | ``` 12 | 13 | ```swift 14 | enum SumType { 15 | case sum1 16 | case sum2 17 | case sum3 18 | } 19 | ``` 20 | 21 | #### A simple product type 22 | ```haskell 23 | data ProductType = ProductType { x :: Int, y :: Int } 24 | getShwifty ''ProductType 25 | ``` 26 | 27 | ```swift 28 | struct ProductType { 29 | let x: Int 30 | let y: Int 31 | } 32 | ``` 33 | 34 | #### A sum type with type variables 35 | ```haskell 36 | data SumType a b = SumL a | SumR b 37 | getShwifty ''SumType 38 | ``` 39 | 40 | ```swift 41 | enum SumType { 42 | case sumL(A) 43 | case sumR(B) 44 | } 45 | ``` 46 | 47 | #### A product type with type variables 48 | ```haskell 49 | data ProductType a b = ProductType 50 | { aField :: a 51 | , bField :: b 52 | } 53 | getShwifty ''ProductType 54 | ``` 55 | 56 | ```swift 57 | struct ProductType { 58 | let aField: A 59 | let bField: B 60 | } 61 | ``` 62 | 63 | #### A newtype 64 | ```haskell 65 | newtype Newtype a = Newtype { getNewtype :: a } 66 | getShwifty ''Newtype 67 | ``` 68 | 69 | ```swift 70 | struct Newtype { 71 | let getNewtype: A 72 | } 73 | ``` 74 | 75 | #### A type with a function field 76 | ```haskell 77 | newtype Endo a = Endo { appEndo :: a -> a } 78 | getShwifty ''Endo 79 | ``` 80 | 81 | ```swift 82 | struct Endo { 83 | let appEndo: ((A) -> A) 84 | } 85 | ``` 86 | 87 | #### A weird type with nested fields. Also note the Result's types being flipped from that of the Either. 88 | ```haskell 89 | data YouveGotProblems a b = YouveGotProblems 90 | { field1 :: Maybe (Maybe (Maybe a)) 91 | , field2 :: Either (Maybe a) (Maybe b) 92 | } 93 | getShwifty ''YouveGotProblems 94 | ``` 95 | 96 | ```swift 97 | struct YouveGotProblems { 98 | let field1: A??? 99 | let field2: Result 100 | } 101 | ``` 102 | 103 | #### A type with polykinded type variables 104 | ```haskell 105 | data PolyKinded (a :: k) = PolyKinded 106 | getShwifty ''PolyKinded 107 | ``` 108 | 109 | ```swift 110 | struct PolyKinded { } 111 | ``` 112 | 113 | #### A sum type where constructors might be records 114 | ```haskell 115 | data SumType a b (c :: k) 116 | = Sum1 Int a (Maybe b) 117 | | Sum2 b 118 | | Sum3 { x :: Int, y :: Int } 119 | getShwifty ''SumType 120 | ``` 121 | 122 | ```swift 123 | enum SumType { 124 | case field1(Int, A, B?) 125 | case field2(B) 126 | case field3(_ x: Int, _ y: Int) 127 | } 128 | ``` 129 | 130 | #### A type containing another type with instance generated by 'getShwifty' 131 | ```haskell 132 | newtype MyFirstType a = MyFirstType { getMyFirstType :: a } 133 | getShwifty ''MyFirstType 134 | 135 | data Contains a = Contains 136 | { x :: MyFirstType Int 137 | , y :: MyFirstType a 138 | } 139 | getShwifty ''Contains 140 | ``` 141 | 142 | ```swift 143 | struct MyFirstType { 144 | let getMyFirstType: A 145 | } 146 | 147 | struct Contains { 148 | let x: MyFirstType 149 | let y: MyFirstType 150 | } 151 | ``` 152 | -------------------------------------------------------------------------------- /src/Shwifty/Class.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | CPP 3 | , FlexibleInstances 4 | , ScopedTypeVariables 5 | , TypeApplications 6 | #-} 7 | 8 | module Shwifty.Class 9 | ( ToSwift(..) 10 | , ToSwiftData(..) 11 | ) where 12 | 13 | import Data.Aeson (Value) 14 | import Data.List (intercalate) 15 | import Data.Proxy (Proxy(..)) 16 | import Control.Monad.Except 17 | import Data.CaseInsensitive (CI) 18 | import Data.Foldable (foldlM,foldr',foldl') 19 | import Data.Functor ((<&>)) 20 | import Data.Int (Int8,Int16,Int32,Int64) 21 | import Data.Kind (Constraint) 22 | import Data.List.NonEmpty ((<|), NonEmpty(..)) 23 | import Data.Maybe (mapMaybe, catMaybes) 24 | import Data.Proxy (Proxy(..)) 25 | import Data.Scientific (Scientific) 26 | import Data.Time (UTCTime) 27 | import Data.UUID.Types (UUID) 28 | import Data.Vector (Vector) 29 | import Data.Void (Void) 30 | import Data.Word (Word8,Word16,Word32,Word64) 31 | import GHC.TypeLits 32 | ( Symbol, KnownSymbol, symbolVal 33 | , TypeError, ErrorMessage(..) 34 | ) 35 | import Language.Haskell.TH hiding (stringE) 36 | import Language.Haskell.TH.Datatype 37 | import Prelude hiding (Enum(..)) 38 | import qualified Data.ByteString as BS 39 | import qualified Data.ByteString.Lazy as BL 40 | import qualified Data.Char as Char 41 | import qualified Data.HashMap.Strict as HM 42 | import qualified Data.List as L 43 | import qualified Data.List.NonEmpty as NE 44 | import qualified Data.Map as M 45 | import qualified Data.Text as TS 46 | import qualified Data.Text.Lazy as TL 47 | import qualified Data.Primitive as Prim 48 | 49 | import Shwifty.Types 50 | 51 | -- | The class for things which can be converted to 52 | -- 'SwiftData'. 53 | -- 54 | -- Typically the instance will be generated by 55 | -- 'getShwifty'. 56 | class ToSwiftData a where 57 | -- | Convert a type to 'SwiftData' 58 | toSwiftData :: Proxy a -> SwiftData 59 | 60 | -- | The class for things which can be converted to 61 | -- a Swift type ('Ty'). 62 | -- 63 | -- Typically the instance will be generated by 64 | -- 'getShwifty'. 65 | class ToSwift a where 66 | -- | Convert a type to its Swift 'Ty'. 67 | toSwift :: Proxy a -> Ty 68 | 69 | instance ToSwift () where 70 | toSwift = const Unit 71 | 72 | instance ToSwift Bool where 73 | toSwift = const Bool 74 | 75 | instance ToSwift UUID where 76 | toSwift = const (Concrete "UUID" []) 77 | 78 | instance ToSwift UTCTime where 79 | toSwift = const (Concrete "Date" []) 80 | 81 | instance forall a b. (ToSwift a, ToSwift b) => ToSwift (a -> b) where 82 | toSwift = const (App (toSwift (Proxy @a)) (toSwift (Proxy @b))) 83 | 84 | instance forall a. ToSwift a => ToSwift (Maybe a) where 85 | toSwift = const (Optional (toSwift (Proxy @a))) 86 | 87 | -- | /Note/: In Swift, the ordering of the type 88 | -- variables is flipped - Shwifty has made the 89 | -- design choice to flip them for you. If you 90 | -- take issue with this, please open an issue 91 | -- for discussion on GitHub. 92 | instance forall a b. (ToSwift a, ToSwift b) => ToSwift (Either a b) where 93 | toSwift = const (Result (toSwift (Proxy @b)) (toSwift (Proxy @a))) 94 | 95 | instance ToSwift Integer where 96 | toSwift = const 97 | #if WORD_SIZE_IN_BITS == 32 98 | BigSInt32 99 | #else 100 | BigSInt64 101 | #endif 102 | 103 | instance ToSwift Int where toSwift = const I 104 | instance ToSwift Int8 where toSwift = const I8 105 | instance ToSwift Int16 where toSwift = const I16 106 | instance ToSwift Int32 where toSwift = const I32 107 | instance ToSwift Int64 where toSwift = const I64 108 | 109 | instance ToSwift Word where toSwift = const U 110 | instance ToSwift Word8 where toSwift = const U8 111 | instance ToSwift Word16 where toSwift = const U16 112 | instance ToSwift Word32 where toSwift = const U32 113 | instance ToSwift Word64 where toSwift = const U64 114 | 115 | instance ToSwift Float where toSwift = const F32 116 | instance ToSwift Double where toSwift = const F64 117 | 118 | instance ToSwift Char where toSwift = const Character 119 | 120 | instance forall a. (ToSwift a) => ToSwift (Prim.Array a) where 121 | toSwift = const (Array (toSwift (Proxy @a))) 122 | 123 | instance forall a. (ToSwift a) => ToSwift (Prim.SmallArray a) where 124 | toSwift = const (Array (toSwift (Proxy @a))) 125 | 126 | instance ToSwift Prim.ByteArray where 127 | toSwift = const (Array U8) 128 | 129 | instance forall a. (ToSwift a) => ToSwift (Prim.PrimArray a) where 130 | toSwift = const (Array (toSwift (Proxy @a))) 131 | 132 | instance forall a. ToSwift a => ToSwift (Vector a) where 133 | toSwift = const (Array (toSwift (Proxy @a))) 134 | 135 | instance {-# overlappable #-} forall a. ToSwift a => ToSwift [a] where 136 | toSwift = const (Array (toSwift (Proxy @a))) 137 | 138 | instance {-# overlapping #-} ToSwift [Char] where toSwift = const Str 139 | 140 | instance ToSwift TL.Text where toSwift = const Str 141 | instance ToSwift TS.Text where toSwift = const Str 142 | 143 | instance ToSwift BL.ByteString where toSwift = const (Array U8) 144 | instance ToSwift BS.ByteString where toSwift = const (Array U8) 145 | 146 | instance ToSwift (CI s) where toSwift = const Str 147 | 148 | instance forall k v. (ToSwift k, ToSwift v) => ToSwift (M.Map k v) where toSwift = const (Dictionary (toSwift (Proxy @k)) (toSwift (Proxy @v))) 149 | 150 | instance forall k v. (ToSwift k, ToSwift v) => ToSwift (HM.HashMap k v) where toSwift = const (Dictionary (toSwift (Proxy @k)) (toSwift (Proxy @v))) 151 | 152 | instance forall a b. (ToSwift a, ToSwift b) => ToSwift ((,) a b) where 153 | toSwift = const (Tuple2 (toSwift (Proxy @a)) (toSwift (Proxy @b))) 154 | 155 | instance forall a b c. (ToSwift a, ToSwift b, ToSwift c) => ToSwift ((,,) a b c) where 156 | toSwift = const (Tuple3 (toSwift (Proxy @a)) (toSwift (Proxy @b)) (toSwift (Proxy @c))) 157 | 158 | instance ToSwiftData Scientific where 159 | toSwiftData _ = SwiftAlias 160 | { aliasName = "Scientific" 161 | , aliasTyVars = [] 162 | , aliasTyp = F64 163 | } 164 | 165 | instance ToSwiftData Value where 166 | toSwiftData _ = SwiftAlias 167 | { aliasName = "Value" 168 | , aliasTyVars = [] 169 | , aliasTyp = Data 170 | } 171 | -------------------------------------------------------------------------------- /src/Shwifty/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | LambdaCase 3 | , RecordWildCards 4 | #-} 5 | 6 | module Shwifty.Pretty 7 | ( prettySwiftData 8 | , prettyTy 9 | ) where 10 | 11 | import Data.List (intercalate) 12 | 13 | import Shwifty.Types 14 | 15 | -- | Pretty-print a 'SwiftData'. 16 | prettySwiftData :: SwiftData -> String 17 | prettySwiftData = prettySwiftDataWith 4 18 | 19 | -- | Pretty-print a 'SwiftData'. 20 | -- This function cares about indent. 21 | prettySwiftDataWith :: () 22 | => Int -- ^ indent 23 | -> SwiftData 24 | -> String 25 | prettySwiftDataWith indent = \case 26 | 27 | SwiftEnum {..} -> [] 28 | ++ "enum " 29 | ++ prettyTypeHeader enumName enumTyVars 30 | ++ prettyRawValueAndProtocols enumRawValue enumProtocols 31 | ++ " {" 32 | ++ newlineNonEmpty enumCases 33 | ++ prettyEnumCases indents enumCases 34 | ++ newlineNonEmpty enumPrivateTypes 35 | ++ prettyPrivateTypes indents enumPrivateTypes 36 | ++ prettyTags indents enumTags 37 | ++ newlineNonEmpty enumTags 38 | ++ "}" 39 | 40 | SwiftStruct {..} -> [] 41 | ++ "struct " 42 | ++ prettyTypeHeader structName structTyVars 43 | ++ prettyProtocols structProtocols 44 | ++ " {" 45 | ++ newlineNonEmpty structFields 46 | ++ prettyStructFields indents structFields 47 | ++ newlineNonEmpty structPrivateTypes 48 | ++ prettyPrivateTypes indents structPrivateTypes 49 | ++ prettyTags indents structTags 50 | ++ newlineNonEmpty structTags 51 | ++ "}" 52 | 53 | SwiftAlias{..} -> [] 54 | ++ "typealias " 55 | ++ prettyTypeHeader aliasName aliasTyVars 56 | ++ " = " 57 | ++ prettyTy aliasTyp 58 | where 59 | indents = replicate indent ' ' 60 | 61 | newlineNonEmpty [] = "" 62 | newlineNonEmpty _ = "\n" 63 | 64 | prettyTypeHeader :: String -> [String] -> String 65 | prettyTypeHeader name [] = name 66 | prettyTypeHeader name tyVars = name ++ "<" ++ intercalate ", " tyVars ++ ">" 67 | 68 | prettyRawValueAndProtocols :: Maybe Ty -> [Protocol] -> String 69 | prettyRawValueAndProtocols Nothing ps = prettyProtocols ps 70 | prettyRawValueAndProtocols (Just ty) [] = ": " ++ prettyTy ty 71 | prettyRawValueAndProtocols (Just ty) ps = ": " ++ prettyTy ty ++ ", " ++ intercalate ", " (map prettyProtocol ps) 72 | 73 | prettyProtocol :: Protocol -> String 74 | prettyProtocol = \case 75 | Equatable -> "Equatable" 76 | Hashable -> "Hashable" 77 | Codable -> "Codable" 78 | OtherProtocol p -> p 79 | 80 | prettyProtocols :: [Protocol] -> String 81 | prettyProtocols = \case 82 | [] -> "" 83 | ps -> ": " ++ intercalate ", " (map show ps) 84 | 85 | prettyTags :: String -> [Ty] -> String 86 | prettyTags indents = go where 87 | go [] = "" 88 | go (Tag{..}:ts) = [] 89 | ++ "\n" 90 | ++ prettyTagDisambiguator tagDisambiguate indents tagName 91 | ++ indents 92 | ++ "typealias " 93 | ++ tagName 94 | ++ " = Tagged<" 95 | ++ (if tagDisambiguate then tagName ++ "Tag" else tagParent) 96 | ++ ", " 97 | ++ prettyTy tagTyp 98 | ++ ">" 99 | ++ go ts 100 | go _ = error "non-tag supplied to prettyTags" 101 | 102 | prettyTagDisambiguator :: () 103 | => Bool 104 | -- ^ disambiguate? 105 | -> String 106 | -- ^ indents 107 | -> String 108 | -- ^ parent type name 109 | -> String 110 | prettyTagDisambiguator disambiguate indents parent 111 | = if disambiguate 112 | then [] 113 | ++ indents 114 | ++ "enum " 115 | ++ parent 116 | ++ "Tag { }\n" 117 | else "" 118 | 119 | labelCase :: Maybe String -> Ty -> String 120 | labelCase Nothing ty = prettyTy ty 121 | labelCase (Just label) ty = "_ " ++ label ++ ": " ++ prettyTy ty 122 | 123 | -- | Pretty-print a 'Ty'. 124 | prettyTy :: Ty -> String 125 | prettyTy = \case 126 | Str -> "String" 127 | Unit -> "()" 128 | Bool -> "Bool" 129 | Character -> "Character" 130 | Tuple2 e1 e2 -> "(" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ")" 131 | Tuple3 e1 e2 e3 -> "(" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ", " ++ prettyTy e3 ++ ")" 132 | Optional e -> prettyTy e ++ "?" 133 | Result e1 e2 -> "Result<" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ">" 134 | Set e -> "Set<" ++ prettyTy e ++ ">" 135 | Dictionary e1 e2 -> "Dictionary<" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ">" 136 | Array e -> "[" ++ prettyTy e ++ "]" 137 | -- App is special, we recurse until we no longer 138 | -- any applications. 139 | App e1 e2 -> prettyApp e1 e2 140 | I -> "Int" 141 | I8 -> "Int8" 142 | I16 -> "Int16" 143 | I32 -> "Int32" 144 | I64 -> "Int64" 145 | U -> "UInt" 146 | U8 -> "UInt8" 147 | U16 -> "UInt16" 148 | U32 -> "UInt32" 149 | U64 -> "UInt64" 150 | F32 -> "Float" 151 | F64 -> "Double" 152 | Decimal -> "Decimal" 153 | BigSInt32 -> "BigSInt32" 154 | BigSInt64 -> "BigSInt64" 155 | Poly ty -> ty 156 | Concrete ty [] -> ty 157 | Concrete ty tys -> ty 158 | ++ "<" 159 | ++ intercalate ", " (map prettyTy tys) 160 | ++ ">" 161 | Tag {..} -> tagParent ++ "." ++ tagName 162 | Data -> "Data" 163 | 164 | prettyApp :: Ty -> Ty -> String 165 | prettyApp t1 t2 = "((" 166 | ++ intercalate ", " (map prettyTy as) 167 | ++ ") -> " 168 | ++ prettyTy r 169 | ++ ")" 170 | where 171 | (as, r) = go t1 t2 172 | go e1 (App e2 e3) = case go e2 e3 of 173 | (args, ret) -> (e1 : args, ret) 174 | go e1 e2 = ([e1], e2) 175 | 176 | prettyEnumCases :: String -> [(String, [(Maybe String, Ty)])] -> String 177 | prettyEnumCases indents = go 178 | where 179 | go = \case 180 | [] -> "" 181 | ((caseNm, []):xs) -> [] 182 | ++ indents 183 | ++ "case " 184 | ++ caseNm 185 | ++ "\n" 186 | ++ go xs 187 | ((caseNm, cs):xs) -> [] 188 | ++ indents 189 | ++ "case " 190 | ++ caseNm 191 | ++ "(" 192 | ++ (intercalate ", " (map (uncurry labelCase) cs)) 193 | ++ ")\n" 194 | ++ go xs 195 | 196 | prettyStructFields :: String -> [(String, Ty)] -> String 197 | prettyStructFields indents = go 198 | where 199 | go [] = "" 200 | go ((fieldName,ty):fs) = indents ++ "let " ++ fieldName ++ ": " ++ prettyTy ty ++ "\n" ++ go fs 201 | 202 | prettyPrivateTypes :: String -> [SwiftData] -> String 203 | prettyPrivateTypes indents = go 204 | where 205 | go [] = "" 206 | go (s:ss) = indents ++ "private " ++ unlines (onLast (indents ++) (lines (prettySwiftData s))) ++ go ss 207 | 208 | -- map a function over everything but the 209 | -- first element. 210 | onLast :: (a -> a) -> [a] -> [a] 211 | onLast f [] = [] 212 | onLast f (x:xs) = x : map f xs 213 | -------------------------------------------------------------------------------- /src/Test.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | AllowAmbiguousTypes 3 | , TemplateHaskell 4 | , ScopedTypeVariables 5 | , DataKinds 6 | , KindSignatures 7 | , PolyKinds 8 | , GADTs 9 | , TypeApplications 10 | , TypeFamilies 11 | , TypeOperators 12 | , QuantifiedConstraints 13 | , FlexibleInstances 14 | #-} 15 | 16 | --{-# options_ghc -ddump-splices #-} 17 | 18 | {-# options_ghc -Wtype-defaults #-} 19 | 20 | module Test where 21 | 22 | import Shwifty 23 | import Data.Proxy 24 | import Data.Kind (Type) 25 | import Data.Void (Void) 26 | import qualified Data.UUID.Types 27 | 28 | data OmitFields0 = OmitFields0 29 | { field01 :: Int 30 | , field02 :: Bool 31 | } 32 | $(getShwiftyWith defaultOptions{omitFields = const Discard} ''OmitFields0) 33 | 34 | data OmitFields1 = OmitFields1 35 | { field11 :: Int 36 | , field12 :: Bool 37 | } 38 | $(getShwiftyWith defaultOptions{omitFields = \s -> if s `elem` ["field11"] then Discard else Keep} ''OmitFields1) 39 | 40 | data OmitCases0 41 | = OmitCases01 42 | | OmitCases02 43 | | OmitCases03 44 | $(getShwiftyWith defaultOptions{omitCases = const Discard} ''OmitCases0) 45 | 46 | data OmitCases1 47 | = OmitCases11 48 | | OmitCases12 49 | | OmitCases13 50 | $(getShwiftyWith defaultOptions{omitCases = \s -> if s `elem` ["OmitCases11"] then Discard else Keep} ''OmitCases1) 51 | 52 | data CodecTest a = CodecTest 53 | { codecTestOne :: a 54 | , codecTestTwo :: Int 55 | } 56 | $( getShwiftyCodec 57 | (Codec @ 58 | ( Drop 'Field "codecTest" 59 | & Implement 'Codable 60 | & DontGenerate ToSwift 61 | & OmitField "codecTestOne" 62 | & MakeBase 'Nothing '[] 63 | ) 64 | ) 65 | 66 | ''CodecTest 67 | ) 68 | 69 | data CodecSum a b 70 | = CodecSumL a 71 | | CodecSumR b 72 | $( getShwiftyCodec 73 | (Codec @ 74 | ( MakeBase ('Just 'Str) '[ Equatable, Hashable, Codable ] 75 | & Drop 'DataCon "CodecSum" 76 | ) 77 | ) 78 | ''CodecSum 79 | ) 80 | 81 | data Fun a b = MkFun 82 | { fun :: Int -> Char -> Bool -> String -> Either a b 83 | } 84 | getShwifty ''Fun 85 | 86 | newtype Lol = MkLol String 87 | newtype Haha = MkHaha String 88 | data Laughs = MkLaughs { lol :: Lol, haha :: Haha } 89 | $(getShwiftyWithTags defaultOptions [ ''Lol, ''Haha ] ''Laughs) 90 | 91 | newtype IsANewtype = MkIsANewtype { getIsANewtype :: String } 92 | $(getShwiftyWith (defaultOptions { newtypeTag = True }) ''IsANewtype) 93 | 94 | data ContainsANewtype = ContainsANewtype 95 | { fieldIsANewtype :: IsANewtype 96 | } 97 | getShwifty ''ContainsANewtype 98 | 99 | data HasRawValue = H1 | H2 100 | $(getShwiftyWith (defaultOptions { dataRawValue = Just Str }) ''HasRawValue) 101 | 102 | newtype AliasTest = AliastTest Int 103 | $(getShwiftyWith (defaultOptions { typeAlias = True }) ''AliasTest) 104 | 105 | -- newtype AliasTestArb a = AliasTestArb { getAliasTestArb :: Maybe a } 106 | -- $(getShwiftyWith (defaultOptions { typeAlias = True }) ''AliasTestArb) 107 | 108 | newtype AliasTestPoly a = AliasTestPoly Int 109 | $(getShwiftyWith (defaultOptions { typeAlias = True }) ''AliasTestPoly) 110 | 111 | newtype EnumTestTag = EnumTestTag Int 112 | 113 | data EnumTest 114 | = Enum1 115 | | Enum2 { enumTestX :: Int } 116 | $(getShwiftyWithTags defaultOptions ([ ''EnumTestTag ]) ''EnumTest) 117 | 118 | class DataClass a where 119 | data family Key a 120 | 121 | instance DataClass Int where 122 | newtype Key Int = IntKey { unIntKey :: Int } 123 | 124 | data HasTags = HasTags { hasTagsX :: Int, hasTagsY :: Int } 125 | 126 | $(getShwiftyWithTags defaultOptions ([ 'IntKey ]) ''HasTags) 127 | 128 | type U = Data.UUID.Types.UUID 129 | 130 | newtype TypeOneId = TypeOneId { getTypeOneId :: U } 131 | newtype TypeTwoId = TypeTwoId { getTypeTwoId :: U } 132 | 133 | data TypeOne = TypeOne 134 | { typeOneId :: TypeOneId 135 | , typeOneX :: Int 136 | } 137 | $(getShwiftyWithTags defaultOptions ([ ''TypeOneId ]) ''TypeOne) 138 | 139 | data TypeTwo = TypeTwo 140 | { typeTwoId :: TypeTwoId 141 | , typeTwoX :: Int 142 | } 143 | $(getShwiftyWithTags defaultOptions ([ ''TypeTwoId ]) ''TypeTwo) 144 | 145 | data TypeThree = TypeThree 146 | { typeThreeHasExternalTag :: TypeTwoId 147 | , typeThreeX :: Int 148 | } 149 | getShwifty ''TypeThree 150 | 151 | data CommonPrefixSum 152 | = CommonPrefixSum1 153 | | CommonPrefixSum2 154 | $(getShwiftyWith (defaultOptions { constructorModifier = drop 12, dataProtocols = [Hashable], dataRawValue = Just Str }) ''CommonPrefixSum) 155 | 156 | data CommonPrefix = CommonPrefix 157 | { commonPrefixA :: Int 158 | , commonPrefixB :: Int 159 | } 160 | $(getShwiftyWith (defaultOptions { fieldLabelModifier = drop 12, dataProtocols = [Codable, Hashable, Equatable] }) ''CommonPrefix) 161 | 162 | data TreeType a = TreeType 163 | { treeTypeField :: Either 164 | ( Either String 165 | ( Either String (Maybe a) 166 | ) 167 | ) 168 | ( Either String 169 | ( Either String (Maybe a) 170 | ) 171 | ) 172 | } 173 | getShwifty ''TreeType 174 | 175 | data Sum = Sum1 | Sum2 | Sum3 | Sum4 176 | getShwifty ''Sum 177 | 178 | newtype Endo a = Endo { appEndo :: a -> a } 179 | getShwifty ''Endo 180 | 181 | newtype N a = N { getN :: a } 182 | getShwifty ''N 183 | 184 | data K a = K { getK :: a, getInt :: Int } 185 | getShwifty ''K 186 | 187 | data M (a :: k) = MkM 188 | getShwifty ''M 189 | 190 | data OneTyVar a = OneTyVar 191 | { one :: Either (Maybe a) (Maybe a) 192 | , two :: Maybe (Maybe (Maybe (Maybe a))) 193 | } 194 | getShwifty ''OneTyVar 195 | 196 | data Z a b = Z { x :: Maybe a, b :: Maybe (Maybe b) } 197 | getShwifty ''Z 198 | 199 | data L a b = L 200 | { l0 :: Int 201 | , l1 :: (a,b,b) 202 | , l2 :: [a] 203 | , l3 :: [b] 204 | } 205 | getShwifty ''L 206 | 207 | data Foo a b (c :: k) 208 | = MkFoo1 Int a (Maybe b) 209 | | MkFoo2 b 210 | | MkFoo3 { intField1 :: Int, intField2 :: Int } 211 | getShwifty ''Foo 212 | 213 | data Contains a = Contains 214 | { m1 :: M Int 215 | , m2 :: M a 216 | , m3 :: Foo (a -> Int) a Int 217 | } 218 | getShwifty ''Contains 219 | 220 | test :: IO () 221 | test = do 222 | testPrint @(Contains X) 223 | testPrint @(Foo X X X) 224 | testPrint @(OneTyVar X) 225 | testPrint @(K X) 226 | testPrint @(Z X X) 227 | testPrint @(L X X) 228 | testPrint @(M X) 229 | testPrint @CommonPrefix 230 | testPrint @CommonPrefixSum 231 | testPrint @HasTags 232 | testPrint @TypeOne 233 | testPrint @TypeTwo 234 | testPrint @TypeThree 235 | testPrint @EnumTest 236 | testPrint @AliasTest 237 | testPrint @(AliasTestPoly X) 238 | testPrint @IsANewtype 239 | testPrint @ContainsANewtype 240 | testPrint @Laughs 241 | testPrint @(Fun X X) 242 | testPrint @(CodecTest X) 243 | testPrint @(CodecSum X X) 244 | testPrint @OmitFields0 245 | testPrint @OmitFields1 246 | testPrint @OmitCases0 247 | testPrint @OmitCases1 248 | --testPrint @(AliasTestArb X) 249 | 250 | testPrint :: forall a. ToSwiftData a => IO () 251 | testPrint = putStrLn $ prettySwiftData $ toSwiftData (Proxy @a) 252 | 253 | --data VoidTest 254 | --getShwifty ''VoidTest 255 | 256 | --data SingleConNonRecordTest 257 | -- = SingleConNonRecordTest Int 258 | --getShwifty ''SingleConNonRecordTest 259 | 260 | --data InfixConTest = Int :+: Int 261 | --getShwifty ''InfixConTest 262 | 263 | --data KindVarRealisationTest (a :: Maybe k) = KindVarRealisationTest 264 | --getShwifty ''KindVarRealisationTest 265 | 266 | --data ExTypsTest = forall x y z. Ex x 267 | --getShwifty ''ExTypsTest 268 | 269 | -------------------------------------------------------------------------------- /src/Shwifty/Codec.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | AllowAmbiguousTypes 3 | , DataKinds 4 | , ExplicitNamespaces 5 | , FlexibleInstances 6 | , GADTs 7 | , KindSignatures 8 | , PolyKinds 9 | , ScopedTypeVariables 10 | , TypeApplications 11 | , TypeFamilies 12 | , TypeOperators 13 | , TypeSynonymInstances 14 | , UndecidableInstances 15 | #-} 16 | 17 | module Shwifty.Codec 18 | ( Codec(..) 19 | , ModifyOptions(..) 20 | , AsIs 21 | , type (&) 22 | , Label(..) 23 | , Drop 24 | , DontGenerate 25 | , Implement 26 | , RawValue 27 | , CanBeRawValue 28 | , TypeAlias 29 | , NewtypeTag 30 | , DontLowercase 31 | , OmitField 32 | , OmitCase 33 | , MakeBase 34 | ) where 35 | 36 | import Data.Kind (Constraint) 37 | import Data.Proxy (Proxy(..)) 38 | import GHC.TypeLits 39 | ( KnownSymbol, Symbol, symbolVal 40 | , TypeError, ErrorMessage(..) 41 | ) 42 | import Shwifty.Class 43 | import Shwifty.Types 44 | 45 | -- | Modify options. 46 | class ModifyOptions tag where 47 | modifyOptions :: Options -> Options 48 | 49 | -- | No modifications 50 | type AsIs = () 51 | 52 | instance ModifyOptions AsIs where 53 | modifyOptions = id 54 | 55 | -- | A carrier for modifiers. 56 | data Codec tag = Codec 57 | 58 | instance ModifyOptions tag => ModifyOptions (Codec tag) where 59 | modifyOptions = modifyOptions @tag 60 | 61 | infixr 6 & 62 | -- | Combine modifications. 63 | data a & b 64 | 65 | instance forall a b. (ModifyOptions a, ModifyOptions b) => ModifyOptions (a & b) where 66 | modifyOptions = modifyOptions @a . modifyOptions @b 67 | 68 | -- | Label modifiers. 69 | data Label 70 | = TyCon 71 | -- ^ Type constructor modifier 72 | | DataCon 73 | -- ^ Data constructor modifiers 74 | | Field 75 | -- ^ Field label modifiers 76 | 77 | -- | Modify a label by dropping a string 78 | data Drop (label :: Label) (string :: Symbol) 79 | 80 | instance KnownSymbol string => ModifyOptions (Drop 'TyCon string) where 81 | modifyOptions options = options 82 | { typeConstructorModifier = drop (length (symbolVal (Proxy @string))) 83 | } 84 | 85 | instance KnownSymbol string => ModifyOptions (Drop 'DataCon string) where 86 | modifyOptions options = options 87 | { constructorModifier = drop (length (symbolVal (Proxy @string))) 88 | } 89 | 90 | instance KnownSymbol string => ModifyOptions (Drop 'Field string) where 91 | modifyOptions options = options 92 | { fieldLabelModifier = drop (length (symbolVal (Proxy @string))) 93 | } 94 | 95 | -- | Don't generate a specific class. 96 | data DontGenerate (cls :: * -> Constraint) 97 | 98 | class GenerateClass (c :: * -> Constraint) where 99 | classModifier :: Options -> Options 100 | 101 | instance GenerateClass ToSwiftData where 102 | classModifier options = options { generateToSwiftData = False } 103 | 104 | instance GenerateClass ToSwift where 105 | classModifier options = options { generateToSwift = False } 106 | 107 | instance GenerateClass c => ModifyOptions (DontGenerate c) where 108 | modifyOptions = classModifier @c 109 | 110 | -- | Add protocols 111 | data Implement (protocol :: Protocol) 112 | 113 | class KnownProtocol (p :: Protocol) where protocolVal :: Protocol 114 | instance KnownProtocol 'Equatable where protocolVal = Equatable 115 | instance KnownProtocol 'Hashable where protocolVal = Hashable 116 | instance KnownProtocol 'Codable where protocolVal = Codable 117 | 118 | instance ModifyOptions (Implement 'Equatable) where 119 | modifyOptions options = options { dataProtocols = Equatable : dataProtocols options } 120 | 121 | instance ModifyOptions (Implement 'Hashable) where 122 | modifyOptions options = options { dataProtocols = Hashable : dataProtocols options } 123 | 124 | instance ModifyOptions (Implement 'Codable) where 125 | modifyOptions options = options { dataProtocols = Codable : dataProtocols options } 126 | 127 | -- | Add a rawValue 128 | data RawValue (ty :: Ty) 129 | 130 | -- | A Class that indicates that this swift type 131 | -- can be a rawValue. The value of 'getRawValue' 132 | -- will be its actual rawValue. 133 | class CanBeRawValue (ty :: Ty) where 134 | getRawValue :: Ty 135 | 136 | instance CanBeRawValue 'Str where getRawValue = Str 137 | instance CanBeRawValue 'I where getRawValue = I 138 | instance CanBeRawValue 'I8 where getRawValue = I8 139 | instance CanBeRawValue 'I16 where getRawValue = I16 140 | instance CanBeRawValue 'I32 where getRawValue = I32 141 | instance CanBeRawValue 'I64 where getRawValue = I64 142 | instance CanBeRawValue 'U where getRawValue = U 143 | instance CanBeRawValue 'U8 where getRawValue = U8 144 | instance CanBeRawValue 'U16 where getRawValue = U16 145 | instance CanBeRawValue 'U32 where getRawValue = U32 146 | instance CanBeRawValue 'U64 where getRawValue = U64 147 | 148 | instance CanBeRawValue ty => ModifyOptions (RawValue ty) where 149 | modifyOptions options = options { dataRawValue = Just (getRawValue @ty) } 150 | 151 | -- | Make it a type alias (only applies to newtypes) 152 | data TypeAlias 153 | 154 | instance ModifyOptions TypeAlias where 155 | modifyOptions options = options { typeAlias = True } 156 | 157 | -- | Make it a newtype tag (only applies to newtype tags) 158 | data NewtypeTag 159 | 160 | instance ModifyOptions NewtypeTag where 161 | modifyOptions options = options { newtypeTag = True } 162 | 163 | -- | Dont lower-case fields/cases 164 | data DontLowercase (someKind :: Label) 165 | 166 | instance TypeError ('Text "Cannot apply DontLowercase to TyCon") => ModifyOptions (DontLowercase 'TyCon) where 167 | modifyOptions _ = error "UNREACHABLE" 168 | 169 | instance ModifyOptions (DontLowercase 'DataCon) where 170 | modifyOptions options = options { lowerFirstCase = False } 171 | 172 | instance ModifyOptions (DontLowercase 'Field) where 173 | modifyOptions options = options { lowerFirstField = False } 174 | 175 | -- | Omit a field 176 | data OmitField (field :: Symbol) 177 | 178 | instance KnownSymbol field => ModifyOptions (OmitField field) where 179 | modifyOptions options = options 180 | { omitFields = let v = symbolVal (Proxy @field) 181 | in \s -> if s == v 182 | then Discard 183 | else omitFields options s 184 | } 185 | 186 | -- | Omit a case 187 | data OmitCase (cas :: Symbol) 188 | 189 | instance KnownSymbol cas => ModifyOptions (OmitCase cas) where 190 | modifyOptions options = options 191 | { omitCases = let v = symbolVal (Proxy @cas) 192 | in \s -> if s == v 193 | then Discard 194 | else omitCases options s 195 | } 196 | 197 | -- | Make a base type 198 | data MakeBase (rawValue :: Maybe Ty) (protocols :: [Protocol]) 199 | 200 | instance forall ty protocols. (CanBeRawValue ty, ProtocolList protocols) => ModifyOptions (MakeBase ('Just ty) protocols) where 201 | modifyOptions options = options 202 | { makeBase = (,,) True (Just (getRawValue @ty)) (protocolList @protocols) 203 | } 204 | 205 | instance forall protocols. (ProtocolList protocols) => ModifyOptions (MakeBase 'Nothing protocols) where 206 | modifyOptions options = options 207 | { makeBase = (,,) True Nothing (protocolList @protocols) 208 | } 209 | 210 | data SomeProtocol where 211 | SomeProtocol :: KnownProtocol p => SomeProtocol 212 | 213 | class ProtocolList (x :: [Protocol]) where 214 | protocolList :: [Protocol] 215 | 216 | instance ProtocolList '[] where 217 | protocolList = [] 218 | 219 | instance forall p ps. (KnownProtocol p, ProtocolList ps) => ProtocolList (p ': ps) where 220 | protocolList = protocolVal @p : protocolList @ps 221 | -------------------------------------------------------------------------------- /src/Shwifty/Types.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | AllowAmbiguousTypes 3 | , DeriveGeneric 4 | , DeriveLift 5 | , DerivingStrategies 6 | #-} 7 | 8 | module Shwifty.Types 9 | ( Ty(..) 10 | , SwiftData(..) 11 | , Protocol(..) 12 | , Options(..) 13 | , KeepOrDiscard(..) 14 | ) where 15 | 16 | import GHC.Generics (Generic) 17 | import Language.Haskell.TH.Syntax (Lift) 18 | 19 | -- | An AST representing a Swift type. 20 | data Ty 21 | = Unit 22 | -- ^ Unit (called "Unit/Void" in swift). Empty struct type. 23 | | Bool 24 | -- ^ Bool 25 | | Character 26 | -- ^ Character 27 | | Str 28 | -- ^ String. Named 'Str' to avoid conflicts with 29 | -- 'Data.Aeson.String'. 30 | | I 31 | -- ^ signed machine integer 32 | | I8 33 | -- ^ signed 8-bit integer 34 | | I16 35 | -- ^ signed 16-bit integer 36 | | I32 37 | -- ^ signed 32-bit integer 38 | | I64 39 | -- ^ signed 64-bit integer 40 | | U 41 | -- ^ unsigned machine integer 42 | | U8 43 | -- ^ unsigned 8-bit integer 44 | | U16 45 | -- ^ unsigned 16-bit integer 46 | | U32 47 | -- ^ unsigned 32-bit integer 48 | | U64 49 | -- ^ unsigned 64-bit integer 50 | | F32 51 | -- ^ 32-bit floating point 52 | | F64 53 | -- ^ 64-bit floating point 54 | | Decimal 55 | -- ^ Increased-precision floating point 56 | | BigSInt32 57 | -- ^ 32-bit big integer 58 | | BigSInt64 59 | -- ^ 64-bit big integer 60 | | Tuple2 Ty Ty 61 | -- ^ 2-tuple 62 | | Tuple3 Ty Ty Ty 63 | -- ^ 3-tuple 64 | | Optional Ty 65 | -- ^ Maybe type 66 | | Result Ty Ty 67 | -- ^ Either type 68 | -- 69 | -- /Note/: The error type in Swift must 70 | -- implement the @Error@ protocol. This library 71 | -- currently does not enforce this. 72 | | Set Ty 73 | -- ^ Set type 74 | | Dictionary Ty Ty 75 | -- ^ Dictionary type 76 | | Array Ty 77 | -- ^ array type 78 | | App Ty Ty 79 | -- ^ function type 80 | | Poly String 81 | -- ^ polymorphic type variable 82 | | Concrete 83 | { concreteName :: String 84 | -- ^ the name of the type 85 | , concreteTyVars :: [Ty] 86 | -- ^ the type's type variables 87 | } 88 | -- ^ a concrete type variable, and its 89 | -- type variables. Will typically be generated 90 | -- by 'getShwifty'. 91 | | Tag 92 | { tagName :: String 93 | -- ^ the name of the type 94 | , tagParent :: String 95 | -- ^ the type constructor of the type 96 | -- to which this alias belongs 97 | , tagTyp :: Ty 98 | -- ^ the type that this represents 99 | , tagDisambiguate :: Bool 100 | -- ^ does the type need disambiguation? 101 | -- 102 | -- This will happen if there are multiple 103 | -- tags with the same type. This is needed 104 | -- to maintain safety. 105 | } 106 | -- ^ A @Tagged@ typealias, for newtyping 107 | -- in a way that doesn't break Codable. 108 | -- 109 | -- See 'getShwiftyWithTags' for examples. 110 | | Data 111 | -- ^ byte buffer in memory 112 | -- See https://developer.apple.com/documentation/foundation/data 113 | deriving stock (Eq, Show, Read) 114 | deriving stock (Generic) 115 | deriving stock (Lift) 116 | 117 | -- | A Swift datatype, either a struct (product type) 118 | -- or enum (sum type). Haskll types are 119 | -- sums-of-products, so the way we differentiate 120 | -- when doing codegen, 121 | -- is that types with a single constructor 122 | -- will be converted to a struct, and those with 123 | -- two or more constructors will be converted to an 124 | -- enum. Types with 0 constructors will be converted 125 | -- to an empty enum. 126 | data SwiftData 127 | = SwiftStruct 128 | { structName :: String 129 | -- ^ The name of the struct 130 | , structTyVars :: [String] 131 | -- ^ The struct's type variables 132 | , structProtocols :: [Protocol] 133 | -- ^ The protocols which the struct 134 | -- implements 135 | , structFields :: [(String, Ty)] 136 | -- ^ The fields of the struct. the pair 137 | -- is interpreted as (name, type). 138 | , structPrivateTypes :: [SwiftData] 139 | -- ^ Private types of the struct. Typically 140 | -- populated by setting 'makeBase'. 141 | , structTags :: [Ty] 142 | -- ^ The tags of the struct. See 'Tag'. 143 | } 144 | -- ^ A struct (product type) 145 | | SwiftEnum 146 | { enumName :: String 147 | -- ^ The name of the enum 148 | , enumTyVars :: [String] 149 | -- ^ The enum's type variables 150 | , enumProtocols :: [Protocol] 151 | -- ^ The protocols which the enum 152 | -- implements 153 | , enumCases :: [(String, [(Maybe String, Ty)])] 154 | -- ^ The cases of the enum. the type 155 | -- can be interpreted as 156 | -- (name, [(label, type)]). 157 | , enumRawValue :: Maybe Ty 158 | -- ^ The rawValue of an enum. See 159 | -- https://developer.apple.com/documentation/swift/rawrepresentable/1540698-rawvalue 160 | -- 161 | -- Typically the 'Ty' will be 162 | -- 'I' or 'String'. 163 | -- 164 | -- /Note/: Currently, nothing will prevent 165 | -- you from putting something 166 | -- nonsensical here. 167 | , enumPrivateTypes :: [SwiftData] 168 | -- ^ Private types of the enum. Typically 169 | -- populated by setting 'makeBase'. 170 | , enumTags :: [Ty] 171 | -- ^ The tags of the struct. See 'Tag'. 172 | } 173 | -- ^ An enum (sum type) 174 | | SwiftAlias 175 | { aliasName :: String 176 | -- ^ the name of the type alias 177 | , aliasTyVars :: [String] 178 | -- ^ the type variables of the type alias 179 | , aliasTyp :: Ty 180 | -- ^ the type this represents (RHS) 181 | } 182 | -- ^ A /top-level/ type alias 183 | deriving stock (Eq, Read, Show, Generic) 184 | 185 | -- | Swift protocols. 186 | -- Only a few are supported right now. 187 | data Protocol 188 | = Hashable 189 | -- ^ The 'Hashable' protocol. 190 | -- See https://developer.apple.com/documentation/swift/hashable 191 | | Codable 192 | -- ^ The 'Codable' protocol. 193 | -- See https://developer.apple.com/documentation/swift/codable 194 | | Equatable 195 | -- ^ The 'Equatable' protocol. 196 | -- See https://developer.apple.com/documentation/swift/equatable 197 | | OtherProtocol String 198 | -- ^ A user-specified protocol. 199 | deriving stock (Eq, Read, Show, Generic) 200 | deriving stock (Lift) 201 | 202 | -- | Options that specify how to 203 | -- encode your 'SwiftData' to a swift type. 204 | -- 205 | -- Options can be set using record syntax on 206 | -- 'defaultOptions' with the fields below. 207 | data Options = Options 208 | { typeConstructorModifier :: String -> String 209 | -- ^ Function applied to type constructor names. 210 | -- The default ('id') makes no changes. 211 | , fieldLabelModifier :: String -> String 212 | -- ^ Function applied to field labels. 213 | -- Handy for removing common record prefixes, 214 | -- for example. The default ('id') makes no 215 | -- changes. 216 | , constructorModifier :: String -> String 217 | -- ^ Function applied to value constructor names. 218 | -- The default ('id') makes no changes. 219 | , optionalExpand :: Bool 220 | -- ^ Whether or not to truncate Optional types. 221 | -- Normally, an Optional ('Maybe') is encoded 222 | -- as "A?", which is syntactic sugar for 223 | -- "Optional\". The default value ('False') 224 | -- will keep it as sugar. A value of 'True' 225 | -- will expand it to be desugared. 226 | , generateToSwift :: Bool 227 | -- ^ Whether or not to generate a 'ToSwift' 228 | -- instance. Sometime this can be desirable 229 | -- if you want to define the instance by hand, 230 | -- or the instance exists elsewhere. 231 | -- The default is 'True', i.e., to generate 232 | -- the instance. 233 | , generateToSwiftData :: Bool 234 | -- ^ Whether or not to generate a 'ToSwiftData' 235 | -- instance. Sometime this can be desirable 236 | -- if you want to define the instance by hand, 237 | -- or the instance exists elsewhere. 238 | -- The default is 'True', i.e., to generate 239 | -- the instance. 240 | , dataProtocols :: [Protocol] 241 | -- ^ Protocols to add to a type. 242 | -- The default (@[]@) will add none. 243 | , dataRawValue :: Maybe Ty 244 | -- ^ The rawValue of an enum. See 245 | -- https://developer.apple.com/documentation/swift/rawrepresentable/1540698-rawvalue 246 | -- 247 | -- The default ('Nothing') will not 248 | -- include any rawValue. 249 | -- 250 | -- Typically, if the type does have 251 | -- a 'rawValue', the 'Ty' will be 252 | -- 'I' or 'Str'. 253 | -- 254 | -- /Note/: Currently, nothing will prevent 255 | -- you from putting something 256 | -- nonsensical here. 257 | , typeAlias :: Bool 258 | -- ^ Whether or not to generate a newtype as 259 | -- a type alias. Consider if you want this 260 | -- or to use 'getShwiftyWithTags' instead. 261 | -- 262 | -- The default ('False') will generate newtypes 263 | -- as their own structs. 264 | , newtypeTag :: Bool 265 | -- ^ Whether or not to generate a newtype as an 266 | -- empty enum with a tag. This is for type 267 | -- safety reasons, but with retaining the 268 | -- ability to have Codable conformance. 269 | -- 270 | -- The default ('False') will not do this. 271 | -- 272 | -- /Note/: This takes priority over 'typeAlias'. 273 | -- 274 | -- /Note/: This option is not currently 275 | -- supported for newtype instances. 276 | -- 277 | -- === __Examples__ 278 | -- 279 | -- > newtype NonEmptyText = MkNonEmptyText String 280 | -- > $(getShwiftyWith (defaultOptions { newtypeTag = True }) ''NonEmpyText) 281 | -- 282 | -- @ 283 | -- enum NonEmptyTextTag { 284 | -- typealias NonEmptyText = Tagged\ 285 | -- } 286 | -- @ 287 | , lowerFirstField :: Bool 288 | -- ^ Whether or not to lower-case the first 289 | -- character of a field after applying all 290 | -- modifiers to it. 291 | -- 292 | -- The default ('True') will do so. 293 | , lowerFirstCase :: Bool 294 | -- ^ Whether or not to lower-case the first 295 | -- character of a case after applying all 296 | -- modifiers to it. 297 | -- 298 | -- The default ('True') will do so. 299 | , omitFields :: String -> KeepOrDiscard 300 | -- ^ Fields to omit from a struct when 301 | -- generating types. 302 | -- 303 | -- The default (@'const' 'Keep'@) will omit nothing. 304 | , omitCases :: String -> KeepOrDiscard 305 | -- ^ Cases to omit from an enum when 306 | -- generating types. 307 | -- 308 | -- The default (@'const' 'Keep'@) will omit nothing. 309 | , makeBase :: (Bool, Maybe Ty, [Protocol]) 310 | -- ^ Whether or not to make a base type, 311 | -- its raw value, and its protocols. 312 | -- 313 | -- Here, "base type" refers to a 314 | -- version of the type without any fields. 315 | -- This can be useful for doing Codable 316 | -- conversions. 317 | -- 318 | -- The default ('False', 'Nothing', @[]@) 319 | -- will not create the base type. 320 | } 321 | 322 | data KeepOrDiscard 323 | = Keep 324 | | Discard 325 | deriving stock (Eq, Ord, Show) 326 | -------------------------------------------------------------------------------- /src/Shwifty.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | AllowAmbiguousTypes 3 | , BangPatterns 4 | , CPP 5 | , DataKinds 6 | , DeriveFoldable 7 | , DeriveFunctor 8 | , DeriveGeneric 9 | , DeriveTraversable 10 | , DerivingStrategies 11 | , FlexibleInstances 12 | , LambdaCase 13 | , MultiWayIf 14 | , NamedFieldPuns 15 | , OverloadedStrings 16 | , RecordWildCards 17 | , ScopedTypeVariables 18 | , TemplateHaskell 19 | , TypeApplications 20 | , TypeFamilies 21 | , TypeOperators 22 | , UndecidableInstances 23 | , ViewPatterns 24 | #-} 25 | 26 | {-# options_ghc 27 | -Wall 28 | -fno-warn-duplicate-exports 29 | #-} 30 | 31 | -- | The Shwifty library allows generation of 32 | -- Swift types (structs and enums) from Haskell 33 | -- ADTs, using Template Haskell. The main 34 | -- entry point to the library should be the 35 | -- documentation and examples of 'getShwifty'. 36 | -- See also 'getShwiftyWith' 37 | -- and 'getShwiftyWithTags'. 38 | -- 39 | -- This library is in alpha and there are a number 40 | -- of known bugs which shouldn't affect most users. 41 | -- See the issue tracker to see what those are. 42 | -- 43 | -- There are probably many bugs/some weird behaviour 44 | -- when it comes to data families. Please report 45 | -- any issues on the issue tracker. 46 | module Shwifty 47 | ( -- * Classes for conversion 48 | ToSwift(..) 49 | , ToSwiftData(..) 50 | 51 | -- * Generating instances 52 | , getShwifty 53 | , getShwiftyWith 54 | , getShwiftyWithTags 55 | 56 | , getShwiftyCodec 57 | , getShwiftyCodecTags 58 | 59 | -- * Types 60 | , Ty(..) 61 | , SwiftData(..) 62 | , Protocol(..) 63 | 64 | -- * Options for encoding types 65 | -- ** Option type 66 | , Options 67 | -- ** Actual Options 68 | , fieldLabelModifier 69 | , constructorModifier 70 | , optionalExpand 71 | , generateToSwift 72 | , generateToSwiftData 73 | , dataProtocols 74 | , dataRawValue 75 | , typeAlias 76 | , newtypeTag 77 | , lowerFirstCase 78 | , lowerFirstField 79 | , omitFields 80 | , omitCases 81 | , makeBase 82 | -- ** Default 'Options' 83 | , defaultOptions 84 | -- ** Helper type for omissions 85 | , KeepOrDiscard(..) 86 | 87 | -- ** Codec options 88 | , Codec(..) 89 | , ModifyOptions(..) 90 | , AsIs 91 | , type (&) 92 | , Label(..) 93 | , Drop 94 | , DontGenerate 95 | , Implement 96 | , RawValue 97 | , CanBeRawValue 98 | , TypeAlias 99 | , NewtypeTag 100 | , DontLowercase 101 | , OmitField 102 | , OmitCase 103 | , MakeBase 104 | 105 | -- * Pretty-printing 106 | -- ** Functions 107 | , prettyTy 108 | , prettySwiftData 109 | -- ** Re-exports 110 | , X 111 | ) where 112 | 113 | import Control.Monad.Except 114 | import Data.Foldable (foldlM,foldr',foldl') 115 | import Data.Functor ((<&>)) 116 | import Data.List.NonEmpty ((<|), NonEmpty(..)) 117 | import Data.Maybe (mapMaybe, catMaybes) 118 | import Data.Proxy (Proxy(..)) 119 | import Data.Void (Void) 120 | import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) 121 | import Language.Haskell.TH hiding (stringE, tupE) 122 | import Language.Haskell.TH.Datatype 123 | import Prelude hiding (Enum(..)) 124 | import qualified Data.Char as Char 125 | import qualified Data.List as L 126 | import qualified Data.List.NonEmpty as NE 127 | import qualified Data.Map as M 128 | import qualified Data.Text as TS 129 | 130 | import Shwifty.Class 131 | import Shwifty.Codec 132 | import Shwifty.Pretty 133 | import Shwifty.Types 134 | 135 | -- | The default 'Options'. 136 | -- 137 | -- @ 138 | -- defaultOptions :: Options 139 | -- defaultOptions = Options 140 | -- { typeConstructorModifier = id 141 | -- , fieldLabelModifier = id 142 | -- , constructorModifier = id 143 | -- , optionalExpand= False 144 | -- , generateToSwift = True 145 | -- , generateToSwiftData = True 146 | -- , dataProtocols = [] 147 | -- , dataRawValue = Nothing 148 | -- , typeAlias = False 149 | -- , newtypeTag = False 150 | -- , lowerFirstField = True 151 | -- , lowerFirstCase = True 152 | -- , omitFields = const Keep 153 | -- , omitCases = const Keep 154 | -- , makeBase = (False, Nothing, []) 155 | -- } 156 | -- @ 157 | -- 158 | defaultOptions :: Options 159 | defaultOptions = Options 160 | { typeConstructorModifier = id 161 | , fieldLabelModifier = id 162 | , constructorModifier = id 163 | , optionalExpand = False 164 | , generateToSwift = True 165 | , generateToSwiftData = True 166 | , dataProtocols = [] 167 | , dataRawValue = Nothing 168 | , typeAlias = False 169 | , newtypeTag = False 170 | , lowerFirstField = True 171 | , lowerFirstCase = True 172 | , omitFields = const Keep 173 | , omitCases = const Keep 174 | , makeBase = (False, Nothing, []) 175 | } 176 | 177 | -- Used internally to reflect polymorphic type 178 | -- variables into TH, then reify them into 'Poly'. 179 | -- 180 | -- See the Rose tree section below 181 | data SingSymbol (x :: Symbol) 182 | instance KnownSymbol x => ToSwift (SingSymbol x) where 183 | toSwift _ = Poly (symbolVal (Proxy @x)) 184 | 185 | -- | A filler type to be used when pretty-printing. 186 | -- The codegen used by shwifty doesn't look at 187 | -- at what a type's type variables are instantiated 188 | -- to, but rather at the type's top-level 189 | -- definition. However, 190 | -- to make GHC happy, you will have to fill in type 191 | -- variables with unused types. To get around this, 192 | -- you could also use something like 193 | -- `-XQuantifiedConstraints`, or existential types, 194 | -- but we leave that to the user to handle. 195 | type X = Void 196 | 197 | ensureEnabled :: Extension -> ShwiftyM () 198 | ensureEnabled ext = do 199 | enabled <- lift $ isExtEnabled ext 200 | unless enabled $ do 201 | throwError $ ExtensionNotEnabled ext 202 | 203 | -- | Generate 'ToSwiftData' and 'ToSwift' instances 204 | -- for your type. 'ToSwift' instances are typically 205 | -- used to build cases or fields, whereas 206 | -- 'ToSwiftData' instances are for building structs 207 | -- and enums. Click the @Examples@ button to see 208 | -- examples of what Swift gets generated in 209 | -- different scenarios. To get access to the 210 | -- generated code, you will have to use one of 211 | -- the pretty-printing functions provided. 212 | -- 213 | -- === __Examples__ 214 | -- 215 | -- > -- A simple sum type 216 | -- > data SumType = Sum1 | Sum2 | Sum3 217 | -- > getShwifty ''SumType 218 | -- 219 | -- @ 220 | -- enum SumType { 221 | -- case sum1 222 | -- case sum2 223 | -- case sum3 224 | -- } 225 | -- @ 226 | -- 227 | -- > -- A simple product type 228 | -- > data ProductType = ProductType { x :: Int, y :: Int } 229 | -- > getShwifty ''ProductType 230 | -- 231 | -- @ 232 | -- struct ProductType { 233 | -- let x: Int 234 | -- let y: Int 235 | -- } 236 | -- @ 237 | -- 238 | -- > -- A sum type with type variables 239 | -- > data SumType a b = SumL a | SumR b 240 | -- > getShwifty ''SumType 241 | -- 242 | -- @ 243 | -- enum SumType\ { 244 | -- case sumL(A) 245 | -- case sumR(B) 246 | -- } 247 | -- @ 248 | -- 249 | -- > -- A product type with type variables 250 | -- > data ProductType a b = ProductType { aField :: a, bField :: b } 251 | -- > getShwifty ''ProductType 252 | -- 253 | -- @ 254 | -- struct ProductType\ { 255 | -- let aField: A 256 | -- let bField: B 257 | -- } 258 | -- @ 259 | -- 260 | -- > -- A newtype 261 | -- > newtype Newtype a = Newtype { getNewtype :: a } 262 | -- > getShwifty ''Newtype 263 | -- 264 | -- @ 265 | -- struct Newtype\ { 266 | -- let getNewtype: A 267 | -- } 268 | -- @ 269 | -- 270 | -- > -- A type with a function field 271 | -- > newtype Endo a = Endo { appEndo :: a -> a } 272 | -- > getShwifty ''Endo 273 | -- 274 | -- @ 275 | -- struct Endo\ { 276 | -- let appEndo: ((A) -> A) 277 | -- } 278 | -- @ 279 | -- 280 | -- > -- A type with a kookier function field 281 | -- > newtype Fun a = Fun { fun :: Int -> Char -> Bool -> String -> Maybe a } 282 | -- > getShwifty ''Fun 283 | -- 284 | -- @ 285 | -- struct Fun\ { 286 | -- let fun: ((Int, Char, Bool, String) -> A?) 287 | -- } 288 | -- @ 289 | -- 290 | -- > -- A weird type with nested fields. Also note the Result's types being flipped from that of the Either. 291 | -- > data YouveGotProblems a b = YouveGotProblems { field1 :: Maybe (Maybe (Maybe a)), field2 :: Either (Maybe a) (Maybe b) } 292 | -- > getShwifty ''YouveGotProblems 293 | -- 294 | -- @ 295 | -- struct YouveGotProblems\ { 296 | -- let field1: Option\\>\> 297 | -- let field2: Result\,Option\\> 298 | -- } 299 | -- @ 300 | -- 301 | -- > -- A type with polykinded type variables 302 | -- > -- Also note that there is no newline because 303 | -- > -- of the absence of fields 304 | -- > data PolyKinded (a :: k) = PolyKinded 305 | -- > getShwifty ''PolyKinded 306 | -- 307 | -- @ 308 | -- struct PolyKinded\ { } 309 | -- @ 310 | -- 311 | -- > -- A sum type where constructors might be records 312 | -- > data SumType a b (c :: k) = Sum1 Int a (Maybe b) | Sum2 b | Sum3 { x :: Int, y :: Int } 313 | -- > getShwifty ''SumType 314 | -- 315 | -- @ 316 | -- enum SumType\ { 317 | -- case field1(Int, A, Optional\) 318 | -- case field2(B) 319 | -- case field3(_ x: Int, _ y: Int) 320 | -- } 321 | -- @ 322 | -- 323 | -- > -- A type containing another type with instance generated by 'getShwifty' 324 | -- > newtype MyFirstType a = MyFirstType { getMyFirstType :: a } 325 | -- > getShwifty ''MyFirstType 326 | -- > 327 | -- > data Contains a = Contains { x :: MyFirstType Int, y :: MyFirstType a } 328 | -- > getShwifty ''Contains 329 | -- 330 | -- @ 331 | -- struct MyFirstType\ { 332 | -- let getMyFirstType: A 333 | -- } 334 | -- 335 | -- struct Contains\ { 336 | -- let x: MyFirstType\ 337 | -- let y: MyFirstType\ 338 | -- } 339 | -- @ 340 | getShwifty :: Name -> Q [Dec] 341 | getShwifty = getShwiftyWith defaultOptions 342 | 343 | -- | Like 'getShwifty', but lets you supply 344 | -- your own 'Options'. Click the examples 345 | -- for some clarification of what you can do. 346 | -- 347 | -- === __Examples__ 348 | -- 349 | -- > data PrefixedFields = MkPrefixedFields { prefixedFieldsX :: Int, prefixedFieldsY :: Int } 350 | -- > $(getShwiftyWith (defaultOptions { fieldLabelModifier = drop (length "PrefixedFields") }) ''PrefixedFields) 351 | -- 352 | -- @ 353 | -- struct PrefixedFields { 354 | -- let x: Int 355 | -- let y: Int 356 | -- } 357 | -- @ 358 | -- 359 | -- > data PrefixedCons = MkPrefixedConsLeft | MkPrefixedConsRight 360 | -- > $(getShwiftyWith (defaultOptions { constructorModifier = drop (length "MkPrefixedCons"), dataProtocols = [Codable] }) ''PrefixedCons) 361 | -- 362 | -- @ 363 | -- enum PrefixedCons: Codable { 364 | -- case left 365 | -- case right 366 | -- } 367 | -- @ 368 | getShwiftyWith :: Options -> Name -> Q [Dec] 369 | getShwiftyWith o n = getShwiftyWithTags o [] n 370 | 371 | data NewtypeInfo = NewtypeInfo 372 | { newtypeName :: Name 373 | -- ^ Type constructor 374 | , newtypeVars :: [TyVarBndr] 375 | -- ^ Type parameters 376 | , newtypeInstTypes :: [Type] 377 | -- ^ Argument types 378 | , newtypeVariant :: DatatypeVariant 379 | -- ^ Whether or not the type is a 380 | -- newtype or newtype instance 381 | , newtypeCon :: ConstructorInfo 382 | } 383 | 384 | -- | Reify a newtype. 385 | reifyNewtype :: Name -> ShwiftyM NewtypeInfo 386 | reifyNewtype n = do 387 | DatatypeInfo{..} <- lift $ reifyDatatype n 388 | case (datatypeCons, datatypeVariant) of 389 | ([c], Newtype) -> do 390 | pure NewtypeInfo { 391 | newtypeName = datatypeName 392 | , newtypeVars = datatypeVars 393 | , newtypeInstTypes = datatypeInstTypes 394 | , newtypeVariant = datatypeVariant 395 | , newtypeCon = c 396 | } 397 | ([c], NewtypeInstance) -> do 398 | pure NewtypeInfo { 399 | newtypeName = datatypeName 400 | , newtypeVars = datatypeVars 401 | , newtypeInstTypes = datatypeInstTypes 402 | , newtypeVariant = datatypeVariant 403 | , newtypeCon = c 404 | } 405 | _ -> do 406 | throwError $ NotANewtype n 407 | 408 | -- Generate the tags for a type. 409 | -- Also generate the ToSwift instance for each tag 410 | -- type. We can't just expect people to do this 411 | -- with a separate 'getShwifty' call, because 412 | -- they will generate the wrong code, since other 413 | -- types with a tag that isn't theirs won't generate 414 | -- well-scoped fields. 415 | getTags :: () 416 | => Name 417 | -- ^ name of parent type 418 | -> [Name] 419 | -- ^ tags 420 | -> ShwiftyM ([Exp], [Dec]) 421 | getTags parentName ts = do 422 | let b = length ts > 1 423 | disambiguate <- lift $ [||b||] 424 | tags <- foldlM 425 | (\(es,ds) n -> do 426 | 427 | NewtypeInfo{..} <- reifyNewtype n 428 | let ConstructorInfo{..} = newtypeCon 429 | 430 | -- generate the tag 431 | let tyconName = case newtypeVariant of 432 | NewtypeInstance -> constructorName 433 | _ -> newtypeName 434 | typ <- case constructorFields of 435 | [ty] -> pure ty 436 | _ -> throwError $ NotANewtype newtypeName 437 | let tag = RecConE 'Tag 438 | [ (mkName "tagName", unqualName tyconName) 439 | , (mkName "tagParent", unqualName parentName) 440 | , (mkName "tagTyp", toSwiftEPoly typ) 441 | , (mkName "tagDisambiguate", unType disambiguate) 442 | ] 443 | 444 | -- generate the instance 445 | !instHeadTy 446 | <- buildTypeInstance newtypeName ClassSwift newtypeInstTypes newtypeVars newtypeVariant 447 | -- we do not want to strip here 448 | clauseTy <- tagToSwift tyconName typ parentName 449 | swiftTyInst <- lift $ instanceD 450 | (pure []) 451 | (pure instHeadTy) 452 | [ funD 'toSwift 453 | [ clause [] (normalB (pure clauseTy)) [] 454 | ] 455 | ] 456 | 457 | pure $ (es ++ [tag], ds ++ [swiftTyInst]) 458 | ) ([], []) ts 459 | pure tags 460 | 461 | getToSwift :: () 462 | => Options 463 | -- ^ options 464 | -> Name 465 | -- ^ type name 466 | -> [Type] 467 | -- ^ type variables 468 | -> [TyVarBndr] 469 | -- ^ type binders 470 | -> DatatypeVariant 471 | -- ^ type variant 472 | -> [ConstructorInfo] 473 | -- ^ constructors 474 | -> ShwiftyM [Dec] 475 | getToSwift Options{..} parentName instTys tyVarBndrs variant cons = if generateToSwift 476 | then do 477 | instHead <- buildTypeInstance parentName ClassSwift instTys tyVarBndrs variant 478 | clauseTy <- case variant of 479 | NewtypeInstance -> case cons of 480 | [ConstructorInfo{..}] -> do 481 | newtypToSwift constructorName instTys 482 | _ -> do 483 | throwError ExpectedNewtypeInstance 484 | _ -> do 485 | typToSwift newtypeTag parentName instTys 486 | inst <- lift $ instanceD 487 | (pure []) 488 | (pure instHead) 489 | [ funD 'toSwift 490 | [ clause [] (normalB (pure clauseTy)) [] 491 | ] 492 | ] 493 | pure [inst] 494 | else do 495 | pure [] 496 | 497 | getToSwiftData :: () 498 | => Options 499 | -- ^ options 500 | -> Name 501 | -- ^ type name 502 | -> [Type] 503 | -- ^ type variables 504 | -> [TyVarBndr] 505 | -- ^ type binders 506 | -> DatatypeVariant 507 | -- ^ type variant 508 | -> [Exp] 509 | -- ^ tags 510 | -> [ConstructorInfo] 511 | -- ^ constructors 512 | -> ShwiftyM [Dec] 513 | getToSwiftData o@Options{..} parentName instTys tyVarBndrs variant tags cons = 514 | if generateToSwiftData 515 | then do 516 | instHead <- buildTypeInstance parentName ClassSwiftData instTys tyVarBndrs variant 517 | clauseData <- consToSwift o parentName instTys variant tags makeBase cons 518 | inst <- lift $ instanceD 519 | (pure []) 520 | (pure instHead) 521 | [ funD 'toSwiftData 522 | [ clause [] (normalB (pure clauseData)) [] 523 | ] 524 | ] 525 | pure [inst] 526 | else do 527 | pure [] 528 | 529 | -- | Like 'getShwiftyWith', but lets you supply 530 | -- tags. Tags are type-safe typealiases that 531 | -- are akin to newtypes in Haskell. The 532 | -- introduction of a struct around something 533 | -- which is, say, a UUID in Swift means that 534 | -- the default Codable instance will not work 535 | -- correctly. So we introduce a tag(s). See the 536 | -- examples to see how this looks. Also, see 537 | -- https://github.com/pointfreeco/swift-tagged, 538 | -- the library which these tags use. The library 539 | -- is not included in any generated code. 540 | -- 541 | -- === __Examples__ 542 | -- 543 | -- > -- Example of using the swift-tagged library: 544 | -- > -- A type containing a database key 545 | -- > data User = User { id :: UserId, name :: Text } 546 | -- > -- the user key 547 | -- > newtype UserId = UserId UUID 548 | -- > $(getShwiftyWithTags defaultOptions [ ''UserId ] ''User) 549 | -- > -- A type that also contains the UserId 550 | -- > data UserDetails = UserDetails { id :: UserId, lastName :: Text } 551 | -- > getShwifty ''UserDetails 552 | -- 553 | -- @ 554 | -- struct User { 555 | -- let id: UserId 556 | -- let name: String 557 | -- 558 | -- typealias UserId = Tagged\ 559 | -- } 560 | -- 561 | -- struct UserDetails { 562 | -- let id: User.UserId 563 | -- let lastName: String 564 | -- } 565 | -- @ 566 | -- 567 | -- > -- Example type with multiple tags 568 | -- > newtype Name = MkName String 569 | -- > newtype Email = MkEmail String 570 | -- > data Person = Person { name :: Name, email :: Email } 571 | -- > $(getShwiftyWithTags defaultOptions [ ''Name, ''Email ] ''Person) 572 | -- 573 | -- @ 574 | -- struct Person { 575 | -- let name: Name 576 | -- let email: Email 577 | -- 578 | -- enum NameTag {} 579 | -- typealias Name = Tagged\ 580 | -- 581 | -- enum EmailTag {} 582 | -- typealias Email = Tagged\ 583 | -- } 584 | -- @ 585 | getShwiftyWithTags :: () 586 | => Options 587 | -> [Name] 588 | -> Name 589 | -> Q [Dec] 590 | getShwiftyWithTags o ts name = do 591 | r <- runExceptT $ do 592 | ensureEnabled ScopedTypeVariables 593 | ensureEnabled DataKinds 594 | DatatypeInfo 595 | { datatypeName = parentName 596 | , datatypeVars = tyVarBndrs 597 | , datatypeInstTypes = instTys 598 | , datatypeVariant = variant 599 | , datatypeCons = cons 600 | } <- lift $ reifyDatatype name 601 | noExistentials cons 602 | 603 | -- get tags/ToSwift instances for tags 604 | (tags, extraDecs) <- getTags parentName ts 605 | 606 | swiftDataInst <- getToSwiftData o parentName instTys tyVarBndrs variant tags cons 607 | 608 | swiftTyInst <- getToSwift o parentName instTys tyVarBndrs variant cons 609 | pure $ swiftDataInst ++ swiftTyInst ++ extraDecs 610 | case r of 611 | Left e -> fail $ prettyShwiftyError e 612 | Right d -> pure d 613 | 614 | noExistentials :: [ConstructorInfo] -> ShwiftyM () 615 | noExistentials cs = forM_ cs $ \ConstructorInfo{..} -> 616 | case (constructorName, constructorVars) of 617 | (_, []) -> do 618 | pure () 619 | (cn, cvs) -> do 620 | throwError $ ExistentialTypes cn cvs 621 | 622 | data ShwiftyError 623 | = SingleConNonRecord 624 | { _conName :: Name 625 | } 626 | | EncounteredInfixConstructor 627 | { _conName :: Name 628 | } 629 | | KindVariableCannotBeRealised 630 | { _typName :: Name 631 | , _kind :: Kind 632 | } 633 | | ExtensionNotEnabled 634 | { _ext :: Extension 635 | } 636 | | ExistentialTypes 637 | { _conName :: Name 638 | , _types :: [TyVarBndr] 639 | } 640 | | ExpectedNewtypeInstance 641 | | NotANewtype 642 | { _typName :: Name 643 | } 644 | 645 | prettyShwiftyError :: ShwiftyError -> String 646 | prettyShwiftyError = \case 647 | SingleConNonRecord (nameStr -> n) -> mempty 648 | ++ n 649 | ++ ": Cannot get shwifty with single-constructor " 650 | ++ "non-record types. This is due to a " 651 | ++ "restriction of Swift that prohibits structs " 652 | ++ "from not having named fields. Try turning " 653 | ++ n ++ " into a record!" 654 | EncounteredInfixConstructor (nameStr -> n) -> mempty 655 | ++ n 656 | ++ ": Cannot get shwifty with infix constructors. " 657 | ++ "Swift doesn't support them. Try changing " 658 | ++ n ++ " into a prefix constructor!" 659 | KindVariableCannotBeRealised (nameStr -> n) typ -> 660 | let (typStr, kindStr) = prettyKindVar typ 661 | in mempty 662 | ++ n 663 | ++ ": Encountered a type variable (" 664 | ++ typStr 665 | ++ ") with a kind (" 666 | ++ kindStr 667 | ++ ") that can't " 668 | ++ "get shwifty! Shwifty needs to be able " 669 | ++ "to realise your kind variables to `*`, " 670 | ++ "since that's all that makes sense in " 671 | ++ "Swift. The only kinds that can happen with " 672 | ++ "are `*` and the free-est kind, `k`." 673 | ExtensionNotEnabled ext -> mempty 674 | ++ show ext 675 | ++ " is not enabled. Shwifty needs it to work!" 676 | -- TODO: make this not print out implicit kinds. 677 | -- e.g. for `data Ex = forall x. Ex x`, there are 678 | -- no implicit `TyVarBndr`s, but for 679 | -- `data Ex = forall x y z. Ex x`, there are two: 680 | -- the kinds inferred by `y` and `z` are both `k`. 681 | -- We print these out - this could be confusing to 682 | -- the end user. I'm not immediately certain how to 683 | -- be rid of them. 684 | ExistentialTypes (nameStr -> n) tys -> mempty 685 | ++ n 686 | ++ " has existential type variables (" 687 | ++ L.intercalate ", " (map prettyTyVarBndrStr tys) 688 | ++ ")! Shwifty doesn't support these." 689 | ExpectedNewtypeInstance -> mempty 690 | ++ "Expected a newtype instance. This is an " 691 | ++ "internal logic error. Please report it as a " 692 | ++ "bug." 693 | NotANewtype (nameStr -> n) -> mempty 694 | ++ n 695 | ++ " is not a newtype. This is an internal logic " 696 | ++ "error. Please report it as a bug." 697 | 698 | prettyTyVarBndrStr :: TyVarBndr -> String 699 | prettyTyVarBndrStr = \case 700 | PlainTV n -> go n 701 | KindedTV n _ -> go n 702 | where 703 | go = TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show 704 | 705 | -- prettify the type and kind. 706 | prettyKindVar :: Type -> (String, String) 707 | prettyKindVar = \case 708 | SigT typ k -> (go typ, go k) 709 | VarT n -> (nameStr n, "*") 710 | typ -> error $ "Shwifty.prettyKindVar: used on a type without a kind signature. Type was: " ++ show typ 711 | where 712 | go = TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show . ppr 713 | 714 | type ShwiftyM = ExceptT ShwiftyError Q 715 | 716 | tagToSwift :: () 717 | => Name 718 | -- ^ name of the type constructor 719 | -> Type 720 | -- ^ type variables 721 | -> Name 722 | -- ^ parent name 723 | -> ShwiftyM Exp 724 | tagToSwift tyconName typ parentName = do 725 | -- TODO: use '_' instead of matching 726 | value <- lift $ newName "value" 727 | ourMatch <- matchProxy 728 | $ tagExp tyconName parentName typ False 729 | let matches = [pure ourMatch] 730 | lift $ lamE [varP value] (caseE (varE value) matches) 731 | newtypToSwift :: () 732 | => Name 733 | -- ^ name of the constructor 734 | -> [Type] 735 | -- ^ type variables 736 | -> ShwiftyM Exp 737 | newtypToSwift conName (stripConT -> instTys) = do 738 | typToSwift False conName instTys 739 | 740 | typToSwift :: () 741 | => Bool 742 | -- ^ is this a newtype tag? 743 | -> Name 744 | -- ^ name of the type 745 | -> [Type] 746 | -- ^ type variables 747 | -> ShwiftyM Exp 748 | typToSwift newtypeTag parentName instTys = do 749 | -- TODO: use '_' instead of matching 750 | value <- lift $ newName "value" 751 | let tyVars = map toSwiftECxt instTys 752 | let name = 753 | let parentStr = nameStr parentName 754 | accessedName = if newtypeTag 755 | then parentStr ++ "Tag." ++ parentStr 756 | else parentStr 757 | in stringE accessedName 758 | ourMatch <- matchProxy 759 | $ RecConE 'Concrete 760 | $ [ (mkName "concreteName", name) 761 | , (mkName "concreteTyVars", ListE tyVars) 762 | ] 763 | let matches = [pure ourMatch] 764 | lift $ lamE [varP value] (caseE (varE value) matches) 765 | 766 | rawValueE :: Maybe Ty -> Exp 767 | rawValueE = \case 768 | Nothing -> ConE 'Nothing 769 | Just ty -> AppE (ConE 'Just) (ParensE (tyE ty)) 770 | 771 | -- god this is annoying. write a cleaner 772 | -- version of this 773 | tyE :: Ty -> Exp 774 | tyE = \case 775 | Unit -> ConE 'Unit 776 | Bool -> ConE 'Bool 777 | Character -> ConE 'Character 778 | Str -> ConE 'Str 779 | I -> ConE 'I 780 | I8 -> ConE 'I8 781 | I16 -> ConE 'I16 782 | I32 -> ConE 'I32 783 | I64 -> ConE 'I64 784 | U -> ConE 'U 785 | U8 -> ConE 'U8 786 | U16 -> ConE 'U16 787 | U32 -> ConE 'U32 788 | U64 -> ConE 'U64 789 | F32 -> ConE 'F32 790 | F64 -> ConE 'F64 791 | Decimal -> ConE 'Decimal 792 | BigSInt32 -> ConE 'BigSInt32 793 | BigSInt64 -> ConE 'BigSInt64 794 | Poly s -> AppE (ConE 'Poly) (stringE s) 795 | Concrete tyCon tyVars -> AppE (AppE (ConE 'Concrete) (stringE tyCon)) (ListE (map tyE tyVars)) 796 | Tuple2 e1 e2 -> AppE (AppE (ConE 'Tuple2) (tyE e1)) (tyE e2) 797 | Tuple3 e1 e2 e3 -> AppE (AppE (AppE (ConE 'Tuple3) (tyE e1)) (tyE e2)) (tyE e3) 798 | Optional e -> AppE (ConE 'Optional) (tyE e) 799 | Result e1 e2 -> AppE (AppE (ConE 'Result) (tyE e1)) (tyE e2) 800 | Set e -> AppE (ConE 'Set) (tyE e) 801 | Dictionary e1 e2 -> AppE (AppE (ConE 'Dictionary) (tyE e1)) (tyE e2) 802 | App e1 e2 -> AppE (AppE (ConE 'App) (tyE e1)) (tyE e2) 803 | Array e -> AppE (ConE 'Array) (tyE e) 804 | Tag{..} -> AppE (AppE (AppE (AppE (ConE 'Tag) (stringE tagName)) (stringE tagParent)) (tyE tagTyp)) (if tagDisambiguate then ConE 'True else ConE 'False) 805 | Data -> ConE 'Data 806 | 807 | consToSwift :: () 808 | => Options 809 | -- ^ options about how to encode things 810 | -> Name 811 | -- ^ name of type 812 | -> [Type] 813 | -- ^ type variables 814 | -> DatatypeVariant 815 | -- ^ data type variant 816 | -> [Exp] 817 | -- ^ tags 818 | -> (Bool, Maybe Ty, [Protocol]) 819 | -- ^ Make base? 820 | -> [ConstructorInfo] 821 | -- ^ constructors 822 | -> ShwiftyM Exp 823 | consToSwift o@Options{..} parentName instTys variant ts bs = \case 824 | [] -> do 825 | value <- lift $ newName "value" 826 | matches <- liftCons (mkVoid parentName instTys ts) 827 | lift $ lamE [varP value] (caseE (varE value) matches) 828 | cons -> do 829 | -- TODO: use '_' instead of matching 830 | value <- lift $ newName "value" 831 | matches <- matchesWorker 832 | lift $ lamE [varP value] (caseE (varE value) matches) 833 | where 834 | -- bad name 835 | matchesWorker :: ShwiftyM [Q Match] 836 | matchesWorker = case cons of 837 | [con] -> liftCons $ do 838 | case variant of 839 | NewtypeInstance -> do 840 | if | typeAlias -> do 841 | mkNewtypeInstanceAlias instTys con 842 | | otherwise -> do 843 | mkNewtypeInstance o instTys ts con 844 | Newtype -> do 845 | if | newtypeTag -> do 846 | mkTypeTag o parentName instTys con 847 | | typeAlias -> do 848 | mkTypeAlias parentName instTys con 849 | | otherwise -> do 850 | mkProd o parentName instTys ts con 851 | _ -> do 852 | mkProd o parentName instTys ts con 853 | _ -> do 854 | -- omit the cases we don't want 855 | let cons' = flip filter cons $ \ConstructorInfo{..} -> omitCases (nameStr constructorName) == Keep 856 | cases <- forM cons' (liftEither . mkCase o) 857 | ourMatch <- matchProxy 858 | $ enumExp parentName instTys dataProtocols cases dataRawValue ts bs 859 | pure [pure ourMatch] 860 | 861 | liftCons :: (Functor f, Applicative g) => f a -> f ([g a]) 862 | liftCons x = ((:[]) . pure) <$> x 863 | 864 | -- Create the case (String, [(Maybe String, Ty)]) 865 | mkCaseHelper :: Options -> Name -> [Exp] -> Exp 866 | mkCaseHelper o name es = tupE [ caseName o name, ListE es ] 867 | 868 | mkCase :: () 869 | => Options 870 | -> ConstructorInfo 871 | -> Either ShwiftyError Exp 872 | mkCase o = \case 873 | -- non-record 874 | ConstructorInfo 875 | { constructorVariant = NormalConstructor 876 | , constructorName = name 877 | , constructorFields = fields 878 | } -> Right $ mkCaseHelper o name $ fields <&> 879 | (\typ -> tupE 880 | [ ConE 'Nothing 881 | , toSwiftEPoly typ 882 | ] 883 | ) 884 | ConstructorInfo 885 | { constructorVariant = InfixConstructor 886 | , constructorName = name 887 | } -> Left $ EncounteredInfixConstructor name 888 | -- records 889 | -- we turn names into labels 890 | ConstructorInfo 891 | { constructorVariant = RecordConstructor fieldNames 892 | , constructorName = name 893 | , constructorFields = fields 894 | } -> 895 | let cases = zipWith (caseField o) fieldNames fields 896 | in Right $ mkCaseHelper o name cases 897 | 898 | caseField :: Options -> Name -> Type -> Exp 899 | caseField o n typ = tupE 900 | [ mkLabel o n 901 | , toSwiftEPoly typ 902 | ] 903 | 904 | onHeadWith :: Bool -> String -> String 905 | onHeadWith toLower = if toLower 906 | then onHead Char.toLower 907 | else id 908 | 909 | -- apply a function only to the head of a string 910 | onHead :: (Char -> Char) -> String -> String 911 | onHead f = \case { [] -> []; (x:xs) -> f x : xs } 912 | 913 | mkLabel :: Options -> Name -> Exp 914 | mkLabel Options{..} = AppE (ConE 'Just) 915 | . stringE 916 | . fieldLabelModifier 917 | . onHeadWith lowerFirstField 918 | . TS.unpack 919 | . last 920 | . TS.splitOn "." 921 | . TS.pack 922 | . show 923 | 924 | mkNewtypeInstanceAlias :: () 925 | => [Type] 926 | -- ^ type variables 927 | -> ConstructorInfo 928 | -- ^ constructor info 929 | -> ShwiftyM Match 930 | mkNewtypeInstanceAlias (stripConT -> instTys) = \case 931 | ConstructorInfo 932 | { constructorName = conName 933 | , constructorFields = [field] 934 | } -> do 935 | lift $ match 936 | (conP 'Proxy []) 937 | (normalB 938 | (pure 939 | (aliasExp conName instTys field))) 940 | [] 941 | _ -> throwError $ ExpectedNewtypeInstance 942 | 943 | mkNewtypeInstance :: () 944 | => Options 945 | -- ^ encoding options 946 | -> [Type] 947 | -- ^ type variables 948 | -> [Exp] 949 | -- ^ tags 950 | -> ConstructorInfo 951 | -- ^ constructor info 952 | -> ShwiftyM Match 953 | mkNewtypeInstance o@Options{..} (stripConT -> instTys) ts = \case 954 | ConstructorInfo 955 | { constructorVariant = RecordConstructor [fieldName] 956 | , constructorFields = [field] 957 | , .. 958 | } -> do 959 | let fields = [prettyField o fieldName field] 960 | matchProxy $ structExp constructorName instTys dataProtocols fields ts makeBase 961 | _ -> throwError ExpectedNewtypeInstance 962 | 963 | -- make a newtype into an empty enum 964 | -- with a tag 965 | mkTypeTag :: () 966 | => Options 967 | -- ^ options 968 | -> Name 969 | -- ^ type name 970 | -> [Type] 971 | -- ^ type variables 972 | -> ConstructorInfo 973 | -- ^ constructor info 974 | -> ShwiftyM Match 975 | mkTypeTag Options{..} typName instTys = \case 976 | ConstructorInfo 977 | { constructorFields = [field] 978 | } -> do 979 | let parentName = mkName 980 | (nameStr typName ++ "Tag") 981 | let tag = tagExp typName parentName field False 982 | matchProxy $ enumExp parentName instTys dataProtocols [] dataRawValue [tag] (False, Nothing, []) 983 | 984 | _ -> throwError $ NotANewtype typName 985 | 986 | -- make a newtype into a type alias 987 | mkTypeAlias :: () 988 | => Name 989 | -- ^ type name 990 | -> [Type] 991 | -- ^ type variables 992 | -> ConstructorInfo 993 | -- ^ constructor info 994 | -> ShwiftyM Match 995 | mkTypeAlias typName instTys = \case 996 | ConstructorInfo 997 | { constructorFields = [field] 998 | } -> do 999 | lift $ match 1000 | (conP 'Proxy []) 1001 | (normalB 1002 | (pure (aliasExp typName instTys field))) 1003 | [] 1004 | _ -> throwError $ NotANewtype typName 1005 | 1006 | -- | Make a void type (empty enum) 1007 | mkVoid :: () 1008 | => Name 1009 | -- ^ type name 1010 | -> [Type] 1011 | -- ^ type variables 1012 | -> [Exp] 1013 | -- ^ tags 1014 | -> ShwiftyM Match 1015 | mkVoid typName instTys ts = matchProxy 1016 | $ enumExp typName instTys [] [] Nothing ts (False, Nothing, []) 1017 | 1018 | -- | Make a single-constructor product (struct) 1019 | mkProd :: () 1020 | => Options 1021 | -- ^ encoding options 1022 | -> Name 1023 | -- ^ type name 1024 | -> [Type] 1025 | -- ^ type variables 1026 | -> [Exp] 1027 | -- ^ tags 1028 | -> ConstructorInfo 1029 | -- ^ constructor info 1030 | -> ShwiftyM Match 1031 | mkProd o@Options{..} typName instTys ts = \case 1032 | -- single constructor, no fields 1033 | ConstructorInfo 1034 | { constructorVariant = NormalConstructor 1035 | , constructorFields = [] 1036 | } -> do 1037 | matchProxy $ structExp typName instTys dataProtocols [] ts makeBase 1038 | -- single constructor, non-record (Normal) 1039 | ConstructorInfo 1040 | { constructorVariant = NormalConstructor 1041 | , constructorName = name 1042 | } -> do 1043 | throwError $ SingleConNonRecord name 1044 | -- single constructor, non-record (Infix) 1045 | ConstructorInfo 1046 | { constructorVariant = InfixConstructor 1047 | , constructorName = name 1048 | } -> do 1049 | throwError $ EncounteredInfixConstructor name 1050 | -- single constructor, record 1051 | ConstructorInfo 1052 | { constructorVariant = RecordConstructor fieldNames 1053 | , .. 1054 | } -> do 1055 | let fields = zipFields o fieldNames constructorFields 1056 | matchProxy $ structExp typName instTys dataProtocols fields ts makeBase 1057 | 1058 | zipFields :: Options -> [Name] -> [Type] -> [Exp] 1059 | zipFields o = zipWithPred p (prettyField o) 1060 | where 1061 | p :: Name -> Type -> Bool 1062 | p n _ = omitFields o (nameStr n) == Keep 1063 | 1064 | zipWithPred :: (a -> b -> Bool) -> (a -> b -> c) -> [a] -> [b] -> [c] 1065 | zipWithPred _ _ [] _ = [] 1066 | zipWithPred _ _ _ [] = [] 1067 | zipWithPred p f (x:xs) (y:ys) 1068 | | p x y = f x y : zipWithPred p f xs ys 1069 | | otherwise = zipWithPred p f xs ys 1070 | 1071 | -- turn a field name into a swift case name. 1072 | -- examples: 1073 | -- 1074 | -- data Foo = A | B | C 1075 | -- => 1076 | -- enum Foo { 1077 | -- case a 1078 | -- case b 1079 | -- case c 1080 | -- } 1081 | -- 1082 | -- data Bar a = MkBar1 a | MkBar2 1083 | -- => 1084 | -- enum Bar { 1085 | -- case mkBar1(A) 1086 | -- case mkBar2 1087 | -- } 1088 | caseName :: Options -> Name -> Exp 1089 | caseName Options{..} = id 1090 | . stringE 1091 | . onHeadWith lowerFirstCase 1092 | . constructorModifier 1093 | . TS.unpack 1094 | . last 1095 | . TS.splitOn "." 1096 | . TS.pack 1097 | . show 1098 | 1099 | -- remove qualifiers from a name, turn into String 1100 | nameStr :: Name -> String 1101 | nameStr = TS.unpack . last . TS.splitOn "." . TS.pack . show 1102 | 1103 | -- remove qualifiers from a name, turn into Exp 1104 | unqualName :: Name -> Exp 1105 | unqualName = stringE . nameStr 1106 | 1107 | -- prettify a type variable as an Exp 1108 | prettyTyVar :: Name -> Exp 1109 | prettyTyVar = stringE . map Char.toUpper . TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show 1110 | 1111 | -- prettify a bunch of type variables as an Exp 1112 | prettyTyVars :: [Type] -> Exp 1113 | prettyTyVars = ListE . map prettyTyVar . getTyVars 1114 | 1115 | -- get the free type variables from many types 1116 | getTyVars :: [Type] -> [Name] 1117 | getTyVars = mapMaybe getFreeTyVar 1118 | 1119 | -- get the free type variables in a type 1120 | getFreeTyVar :: Type -> Maybe Name 1121 | getFreeTyVar = \case 1122 | VarT name -> Just name 1123 | SigT (VarT name) _kind -> Just name 1124 | _ -> Nothing 1125 | 1126 | -- make a struct field pretty 1127 | prettyField :: Options -> Name -> Type -> Exp 1128 | prettyField Options{..} name ty = tupE 1129 | [ (stringE (onHeadWith lowerFirstField (fieldLabelModifier (nameStr name)))) 1130 | , toSwiftEPoly ty 1131 | ] 1132 | 1133 | -- build the instance head for a type 1134 | buildTypeInstance :: () 1135 | => Name 1136 | -- ^ name of the type 1137 | -> ShwiftyClass 1138 | -- ^ which class instance head we are building 1139 | -> [Type] 1140 | -- ^ type variables 1141 | -> [TyVarBndr] 1142 | -- ^ the binders for our tyvars 1143 | -> DatatypeVariant 1144 | -- ^ variant (datatype, newtype, data family, newtype family) 1145 | -> ShwiftyM Type 1146 | buildTypeInstance tyConName cls varTysOrig tyVarBndrs variant = do 1147 | -- Make sure to expand through type/kind synonyms! 1148 | -- Otherwise, the eta-reduction check might get 1149 | -- tripped up over type variables in a synonym 1150 | -- that are actually dropped. 1151 | -- (See GHC Trac #11416 for a scenario where this 1152 | -- actually happened) 1153 | varTysExp <- lift $ mapM resolveTypeSynonyms varTysOrig 1154 | 1155 | -- get the kind status of all of our types. 1156 | -- we must realise them all to *. 1157 | starKindStats :: [KindStatus] <- foldlM 1158 | (\stats k -> case canRealiseKindStar k of 1159 | NotKindStar -> do 1160 | throwError $ KindVariableCannotBeRealised tyConName k 1161 | s -> pure (stats ++ [s]) 1162 | ) [] varTysExp 1163 | 1164 | let -- get the names of our kind vars 1165 | kindVarNames :: [Name] 1166 | kindVarNames = flip mapMaybe starKindStats 1167 | (\case 1168 | IsKindVar n -> Just n 1169 | _ -> Nothing 1170 | ) 1171 | 1172 | let 1173 | -- instantiate polykinded things to star. 1174 | varTysExpSubst :: [Type] 1175 | varTysExpSubst = map (substNamesWithKindStar kindVarNames) varTysExp 1176 | 1177 | -- the constraints needed on type variables 1178 | preds :: [Maybe Pred] 1179 | preds = map (deriveConstraint cls) varTysExpSubst 1180 | 1181 | -- We now sub all of the specialised-to-* kind 1182 | -- variable names with *, but in the original types, 1183 | -- not the synonym-expanded types. The reason we 1184 | -- do this is superficial: we want the derived 1185 | -- instance to resemble the datatype written in 1186 | -- source code as closely as possible. For example, 1187 | -- 1188 | -- data family Fam a 1189 | -- newtype instance Fam String = Fam String 1190 | -- 1191 | -- We'd want to generate the instance: 1192 | -- 1193 | -- instance C (Fam String) 1194 | -- 1195 | -- Not: 1196 | -- 1197 | -- instance C (Fam [Char]) 1198 | varTysOrigSubst :: [Type] 1199 | varTysOrigSubst = 1200 | map (substNamesWithKindStar kindVarNames) $ varTysOrig 1201 | 1202 | -- if we are working on a data family 1203 | -- or newtype family, we need to peel off 1204 | -- the kinds. See Note [Kind signatures in 1205 | -- derived instances] 1206 | varTysOrigSubst' :: [Type] 1207 | varTysOrigSubst' = if isDataFamily variant 1208 | then varTysOrigSubst 1209 | else map unSigT varTysOrigSubst 1210 | 1211 | -- the constraints needed on type variables 1212 | -- makes up the constraint part of the 1213 | -- instance head. 1214 | instanceCxt :: Cxt 1215 | instanceCxt = catMaybes preds 1216 | 1217 | -- the class and type in the instance head. 1218 | instanceType :: Type 1219 | instanceType = AppT (ConT (shwiftyClassName cls)) 1220 | $ applyTyCon tyConName varTysOrigSubst' 1221 | 1222 | -- forall . ctx tys => Cls ty 1223 | lift $ forallT 1224 | (map tyVarBndrNoSig tyVarBndrs) 1225 | (pure instanceCxt) 1226 | (pure instanceType) 1227 | 1228 | -- the class we're generating an instance of 1229 | data ShwiftyClass 1230 | = ClassSwift -- ToSwift 1231 | | ClassSwiftData -- ToSwiftData 1232 | 1233 | -- turn a 'ShwiftyClass' into a 'Name' 1234 | shwiftyClassName :: ShwiftyClass -> Name 1235 | shwiftyClassName = \case 1236 | ClassSwift -> ''ToSwift 1237 | ClassSwiftData -> ''ToSwiftData 1238 | 1239 | -- derive the constraint needed on a type variable 1240 | -- in order to build the instance head for a class. 1241 | deriveConstraint :: () 1242 | => ShwiftyClass 1243 | -- ^ class name 1244 | -> Type 1245 | -- ^ type 1246 | -> Maybe Pred 1247 | -- ^ constraint on type 1248 | deriveConstraint c@ClassSwift typ 1249 | | not (isTyVar typ) = Nothing 1250 | | hasKindStar typ = Just (applyCon (shwiftyClassName c) tName) 1251 | | otherwise = Nothing 1252 | where 1253 | tName :: Name 1254 | tName = varTToName typ 1255 | varTToName = \case 1256 | VarT n -> n 1257 | SigT t _ -> varTToName t 1258 | _ -> error "Shwifty.varTToName: encountered non-type variable" 1259 | deriveConstraint ClassSwiftData _ = Nothing 1260 | 1261 | -- apply a type constructor to a type variable. 1262 | -- this can be useful for letting the kind 1263 | -- inference engine doing work for you. see 1264 | -- 'toSwiftECxt' for an example of this. 1265 | applyCon :: Name -> Name -> Pred 1266 | applyCon con t = AppT (ConT con) (VarT t) 1267 | 1268 | -- peel off a kind signature from a Type 1269 | unSigT :: Type -> Type 1270 | unSigT = \case 1271 | SigT t _ -> t 1272 | t -> t 1273 | 1274 | -- is the type a type variable? 1275 | isTyVar :: Type -> Bool 1276 | isTyVar = \case 1277 | VarT _ -> True 1278 | SigT t _ -> isTyVar t 1279 | _ -> False 1280 | 1281 | -- does the type have kind *? 1282 | hasKindStar :: Type -> Bool 1283 | hasKindStar = \case 1284 | VarT _ -> True 1285 | SigT _ StarT -> True 1286 | _ -> False 1287 | 1288 | -- perform the substitution of type variables 1289 | -- who have kinds which can be realised to *, 1290 | -- with the same type variable where its kind 1291 | -- has been turned into * 1292 | substNamesWithKindStar :: [Name] -> Type -> Type 1293 | substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns 1294 | where 1295 | substNameWithKind :: Name -> Kind -> Type -> Type 1296 | substNameWithKind n k = applySubstitution (M.singleton n k) 1297 | 1298 | -- | The status of a kind variable w.r.t. its 1299 | -- ability to be realised into *. 1300 | data KindStatus 1301 | = KindStar 1302 | -- ^ kind * (or some k which can be realised to *) 1303 | | NotKindStar 1304 | -- ^ any other kind 1305 | | IsKindVar Name 1306 | -- ^ is actually a kind variable 1307 | | IsCon Name 1308 | -- ^ is a constructor - this will typically 1309 | -- happen in a data family instance, because 1310 | -- we often have to construct a 1311 | -- FlexibleInstance. our old check for 1312 | -- canRealiseKindStar didn't check for 1313 | -- `ConT` - where this would happen. 1314 | -- 1315 | -- TODO: Now i think this might need to be 1316 | -- removed in favour of something smarter. 1317 | 1318 | -- can we realise the type's kind to *? 1319 | canRealiseKindStar :: Type -> KindStatus 1320 | canRealiseKindStar = \case 1321 | VarT{} -> KindStar 1322 | SigT _ StarT -> KindStar 1323 | SigT _ (VarT n) -> IsKindVar n 1324 | ConT n -> IsCon n 1325 | _ -> NotKindStar 1326 | 1327 | -- discard the kind signature from a TyVarBndr. 1328 | tyVarBndrNoSig :: TyVarBndr -> TyVarBndr 1329 | tyVarBndrNoSig = \case 1330 | PlainTV n -> PlainTV n 1331 | KindedTV n _k -> PlainTV n 1332 | 1333 | -- fully applies a type constructor to its 1334 | -- type variables 1335 | applyTyCon :: Name -> [Type] -> Type 1336 | applyTyCon = foldl' AppT . ConT 1337 | 1338 | -- Turn a String into an Exp string literal 1339 | stringE :: String -> Exp 1340 | stringE = LitE . StringL 1341 | 1342 | -- convert a type into a 'Ty'. 1343 | -- we respect constraints here - e.g. in 1344 | -- `(Swift a, Swift b) => Swift (Foo a b)`, 1345 | -- we don't just fill in holes like in 1346 | -- `toSwiftEPoly`, we actually turn `a` 1347 | -- and `b` into `Ty`s directly. Consequently, 1348 | -- the implementation is much simpler - just 1349 | -- an application. 1350 | -- 1351 | -- Note the use of unSigT - see Note 1352 | -- [Kind signatures in derived instances]. 1353 | toSwiftECxt :: Type -> Exp 1354 | toSwiftECxt (unSigT -> typ) = AppE 1355 | (VarE 'toSwift) 1356 | (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ)) 1357 | 1358 | -- convert a type into a 'Ty'. 1359 | -- polymorphic types do not require a 'ToSwift' 1360 | -- instance, since we fill them in with 'SingSymbol'. 1361 | -- 1362 | -- We do this by stretching out a type along its 1363 | -- spine, completely. we then fill in any polymorphic 1364 | -- variables with 'SingSymbol', reflecting the type 1365 | -- Name to a Symbol. then we compress the spine to 1366 | -- get the original type. the 'ToSwift' instance for 1367 | -- 'SingSymbol' gets us where we need to go. 1368 | -- 1369 | -- Note that @compress . decompress@ is not 1370 | -- actually equivalent to the identity function on 1371 | -- Type because of ForallT, where we discard some 1372 | -- context. However, for any types we care about, 1373 | -- there shouldn't be a ForallT, so this *should* 1374 | -- be fine. 1375 | toSwiftEPoly :: Type -> Exp 1376 | toSwiftEPoly = \case 1377 | -- we don't need to special case VarT and SigT 1378 | VarT n 1379 | -> AppE (ConE 'Poly) (prettyTyVar n) 1380 | SigT (VarT n) _ 1381 | -> AppE (ConE 'Poly) (prettyTyVar n) 1382 | typ -> 1383 | let decompressed = decompress typ 1384 | prettyName = map Char.toUpper . TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show 1385 | filledInHoles = decompressed <&> 1386 | (\case 1387 | VarT name -> AppT 1388 | (ConT ''Shwifty.SingSymbol) 1389 | (LitT (StrTyLit (prettyName name))) 1390 | SigT (VarT name) _ -> AppT 1391 | (ConT ''Shwifty.SingSymbol) 1392 | (LitT (StrTyLit (prettyName name))) 1393 | t -> t 1394 | ) 1395 | typ' = compress filledInHoles 1396 | in AppE 1397 | (VarE 'toSwift) 1398 | (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ')) 1399 | 1400 | decompress :: Type -> Rose Type 1401 | decompress typ = case unapplyTy typ of 1402 | tyCon :| tyArgs -> Rose tyCon (decompress <$> tyArgs) 1403 | 1404 | compress :: Rose Type -> Type 1405 | compress (Rose typ []) = typ 1406 | compress (Rose t ts) = foldl' AppT t (compress <$> ts) 1407 | 1408 | unapplyTy :: Type -> NonEmpty Type 1409 | unapplyTy = NE.reverse . go 1410 | where 1411 | go = \case 1412 | AppT t1 t2 -> t2 <| go t1 1413 | SigT t _ -> go t 1414 | ForallT _ _ t -> go t 1415 | t -> t :| [] 1416 | 1417 | -- | Types can be stretched out into a Rose tree. 1418 | -- decompress will stretch a type out completely, 1419 | -- in such a way that it cannot be stretched out 1420 | -- further. compress will reconstruct a type from 1421 | -- its stretched form. 1422 | -- 1423 | -- Also note that this is equivalent to 1424 | -- Cofree NonEmpty Type. 1425 | -- 1426 | -- Examples: 1427 | -- 1428 | -- Maybe a 1429 | -- => 1430 | -- AppT (ConT Maybe) (VarT a) 1431 | -- 1432 | -- 1433 | -- Either a b 1434 | -- => 1435 | -- AppT (AppT (ConT Either) (VarT a)) (VarT b) 1436 | -- => 1437 | -- Rose (ConT Either) 1438 | -- [ Rose (VarT a) 1439 | -- [ 1440 | -- ] 1441 | -- , Rose (VarT b) 1442 | -- [ 1443 | -- ] 1444 | -- ] 1445 | -- 1446 | -- 1447 | -- Either (Maybe a) (Maybe b) 1448 | -- => 1449 | -- AppT (AppT (ConT Either) (AppT (ConT Maybe) (VarT a))) (AppT (ConT Maybe) (VarT b)) 1450 | -- => 1451 | -- Rose (ConT Either) 1452 | -- [ Rose (ConT Maybe) 1453 | -- [ Rose (VarT a) 1454 | -- [ 1455 | -- ] 1456 | -- ] 1457 | -- , Rose (ConT Maybe) 1458 | -- [ Rose (VarT b) 1459 | -- [ 1460 | -- ] 1461 | -- ] 1462 | -- ] 1463 | data Rose a = Rose a [Rose a] 1464 | deriving stock (Eq, Show) 1465 | deriving stock (Functor,Foldable,Traversable) 1466 | 1467 | {- 1468 | Note [Kind signatures in derived instances] 1469 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1470 | 1471 | It is possible to put explicit kind signatures into the derived instances, e.g., 1472 | 1473 | instance C a => C (Data (f :: * -> *)) where ... 1474 | 1475 | But it is preferable to avoid this if possible. If we come up with an incorrect 1476 | kind signature (which is entirely possible, since Template Haskell doesn't always 1477 | have the best track record with reifying kind signatures), then GHC will flat-out 1478 | reject the instance, which is quite unfortunate. 1479 | 1480 | Plain old datatypes have the advantage that you can avoid using any kind signatures 1481 | at all in their instances. This is because a datatype declaration uses all type 1482 | variables, so the types that we use in a derived instance uniquely determine their 1483 | kinds. As long as we plug in the right types, the kind inferencer can do the rest 1484 | of the work. For this reason, we use unSigT to remove all kind signatures before 1485 | splicing in the instance context and head. 1486 | 1487 | Data family instances are trickier, since a data family can have two instances that 1488 | are distinguished by kind alone, e.g., 1489 | 1490 | data family Fam (a :: k) 1491 | data instance Fam (a :: * -> *) 1492 | data instance Fam (a :: *) 1493 | 1494 | If we dropped the kind signatures for C (Fam a), then GHC will have no way of 1495 | knowing which instance we are talking about. To avoid this scenario, we always 1496 | include explicit kind signatures in data family instances. There is a chance that 1497 | the inferred kind signatures will be incorrect, in which case we have to write the instance manually. 1498 | -} 1499 | 1500 | -- are we working on a data family 1501 | -- or newtype family? 1502 | isDataFamily :: DatatypeVariant -> Bool 1503 | isDataFamily = \case 1504 | NewtypeInstance -> True 1505 | DataInstance -> True 1506 | _ -> False 1507 | 1508 | stripConT :: [Type] -> [Type] 1509 | stripConT = mapMaybe noConT 1510 | where 1511 | noConT = \case 1512 | ConT {} -> Nothing 1513 | t -> Just t 1514 | 1515 | -- | Like 'getShwiftyWith', but with a 'Codec' 1516 | -- instead of 'Options'. 1517 | getShwiftyCodec :: forall tag. ModifyOptions tag => Codec tag -> Name -> Q [Dec] 1518 | getShwiftyCodec c = getShwiftyCodecTags c [] 1519 | 1520 | -- | Like 'getShwiftyWithTags', but with a 'Codec' 1521 | -- instead of 'Options'. 1522 | getShwiftyCodecTags :: forall tag. ModifyOptions tag => Codec tag -> [Name] -> Name -> Q [Dec] 1523 | getShwiftyCodecTags _ ts n = getShwiftyWithTags (modifyOptions @tag defaultOptions) ts n 1524 | 1525 | --getShwiftyModTags :: forall tag typ. (ModifyOptions tag, KnownSymbol typ) => [Name] -> Q [Dec] 1526 | --getShwiftyModTags ts = getShwiftyWithTags (modifyOptions @tag defaultOptions) ts (mkName (symbolVal (Proxy @typ))) 1527 | 1528 | --combine :: Codec a -> Codec b -> Codec (a & b) 1529 | --combine _ _ = Codec 1530 | 1531 | -- | Construct a Type Alias. 1532 | aliasExp :: () 1533 | => Name 1534 | -- ^ alias name 1535 | -> [Type] 1536 | -- ^ type variables 1537 | -> Type 1538 | -- ^ type (RHS) 1539 | -> Exp 1540 | aliasExp name tyVars field = RecConE 'SwiftAlias 1541 | [ (mkName "aliasName", unqualName name) 1542 | , (mkName "aliasTyVars", prettyTyVars tyVars) 1543 | , (mkName "aliasTyp", toSwiftECxt field) 1544 | ] 1545 | 1546 | -- | Construct a Tag. 1547 | tagExp :: () 1548 | => Name 1549 | -- ^ tycon name 1550 | -> Name 1551 | -- ^ parent name 1552 | -> Type 1553 | -- ^ type of the tag (RHS) 1554 | -> Bool 1555 | -- ^ Whether or not we are disambiguating. 1556 | -> Exp 1557 | tagExp tyconName parentName typ dis = RecConE 'Tag 1558 | [ (mkName "tagName", unqualName tyconName) 1559 | , (mkName "tagParent", unqualName parentName) 1560 | , (mkName "tagTyp", toSwiftECxt typ) 1561 | , (mkName "tagDisambiguate", case dis of 1562 | { False -> ConE 'False 1563 | ; True -> ConE 'True 1564 | }) 1565 | ] 1566 | 1567 | -- | Construct an Enum. 1568 | enumExp :: () 1569 | => Name 1570 | -- ^ parent name 1571 | -> [Type] 1572 | -- ^ type variables 1573 | -> [Protocol] 1574 | -- ^ protocols 1575 | -> [Exp] 1576 | -- ^ cases 1577 | -> Maybe Ty 1578 | -- ^ Raw Value 1579 | -> [Exp] 1580 | -- ^ Tags 1581 | -> (Bool, Maybe Ty, [Protocol]) 1582 | -- ^ Make base? 1583 | -> Exp 1584 | enumExp parentName tyVars protos cases raw tags bs 1585 | = applyBase bs $ RecConE 'SwiftEnum 1586 | [ (mkName "enumName", unqualName parentName) 1587 | , (mkName "enumTyVars", prettyTyVars tyVars) 1588 | , (mkName "enumProtocols", protosExp protos) 1589 | , (mkName "enumCases", ListE cases) 1590 | , (mkName "enumRawValue", rawValueE raw) 1591 | , (mkName "enumPrivateTypes", ListE []) 1592 | , (mkName "enumTags", ListE tags) 1593 | ] 1594 | 1595 | -- | Construct a Struct. 1596 | structExp :: () 1597 | => Name 1598 | -- ^ struct name 1599 | -> [Type] 1600 | -- ^ type variables 1601 | -> [Protocol] 1602 | -- ^ protocols 1603 | -> [Exp] 1604 | -- ^ fields 1605 | -> [Exp] 1606 | -- ^ tags 1607 | -> (Bool, Maybe Ty, [Protocol]) 1608 | -- ^ Make base? 1609 | -> Exp 1610 | structExp name tyVars protos fields tags bs 1611 | = applyBase bs $ RecConE 'SwiftStruct 1612 | [ (mkName "structName", unqualName name) 1613 | , (mkName "structTyVars", prettyTyVars tyVars) 1614 | , (mkName "structProtocols", protosExp protos) 1615 | , (mkName "structFields", ListE fields) 1616 | , (mkName "structPrivateTypes", ListE []) 1617 | , (mkName "structTags", ListE tags) 1618 | ] 1619 | 1620 | matchProxy :: Exp -> ShwiftyM Match 1621 | matchProxy e = lift $ match 1622 | (conP 'Proxy []) 1623 | (normalB (pure e)) 1624 | [] 1625 | 1626 | stripFields :: SwiftData -> SwiftData 1627 | stripFields = \case 1628 | s@SwiftStruct{} -> s { structFields = [] } 1629 | s@SwiftEnum{} -> s { enumCases = go (enumCases s) } 1630 | where 1631 | go = map stripOne 1632 | stripOne (x, _) = (x, []) 1633 | s -> s 1634 | 1635 | giveProtos :: [Protocol] -> SwiftData -> SwiftData 1636 | giveProtos ps = \case 1637 | s@SwiftStruct{} -> s { structProtocols = ps } 1638 | s@SwiftEnum{} -> s { enumProtocols = ps } 1639 | s -> s 1640 | 1641 | suffixBase :: SwiftData -> SwiftData 1642 | suffixBase = \case 1643 | s@SwiftStruct{} -> s { structName = structName s ++ "Base" } 1644 | s@SwiftEnum{} -> s { enumName = enumName s ++ "Base" } 1645 | s -> s 1646 | 1647 | giveBase :: Maybe Ty -> [Protocol] -> SwiftData -> SwiftData 1648 | giveBase r ps = \case 1649 | s@SwiftStruct{} -> s { structPrivateTypes = [giveProtos ps (suffixBase (stripFields s))] } 1650 | s@SwiftEnum{} -> s { enumPrivateTypes = [ giveProtos ps (suffixBase (stripFields s)) { enumRawValue = r }] } 1651 | s -> s 1652 | 1653 | -- | Apply 'giveBase' to a 'SwiftData'. 1654 | -- 1655 | -- Ideally we would offload this into 1656 | -- the first construction of the SwiftData, 1657 | -- inside structExp/enumExp. 1658 | -- 1659 | -- 1660 | -- should we strip tyvars as well? 1661 | applyBase :: (Bool, Maybe Ty, [Protocol]) -> Exp -> Exp 1662 | applyBase (b, r, ps) (ParensE -> s) = if b 1663 | then 1664 | AppE (AppE (AppE (VarE 'giveBase) (rawValueE r)) (protosExp ps)) s 1665 | else s 1666 | 1667 | protosExp :: [Protocol] -> Exp 1668 | protosExp = ListE . map (ConE . mkName . show) 1669 | 1670 | tupE :: [Exp] -> Exp 1671 | #if MIN_VERSION_template_haskell(2,16,0) 1672 | tupE = TupE . map Just 1673 | #else 1674 | tupE = TupE 1675 | #endif 1676 | --------------------------------------------------------------------------------