shwifty (empty) → 0.0.1.0
raw patch · 5 files changed
+2403/−0 lines, 5 filesdep +basedep +bytestringdep +case-insensitive
Dependencies added: base, bytestring, case-insensitive, containers, mtl, primitive, template-haskell, text, th-abstraction, time, unordered-containers, uuid-types, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +7/−0
- README.md +151/−0
- shwifty.cabal +59/−0
- src/Shwifty.hs +2181/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for shwifty++## 0.0.1.0 -- 2020-02-03++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright 2019 chessai++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:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++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.
+ README.md view
@@ -0,0 +1,151 @@+# Shwifty++## Generate Swift types from Haskell types++Examples: ++#### A simple sum type+```haskell+data SumType = Sum1 | Sum2 | Sum3+getShwifty ''SumType+```++```swift+enum SumType {+ case sum1+ case sum2+ case sum3+}+```++#### A simple product type+```haskell+data ProductType = ProductType { x :: Int, y :: Int }+getShwifty ''ProductType+```++```swift+struct ProductType {+ let x: Int+ let y: Int+}+```++#### A sum type with type variables+```haskell+data SumType a b = SumL a | SumR b+getShwifty ''SumType+```++```swift+enum SumType<A, B> {+ case sumL(A)+ case sumR(B)+}+```++#### A product type with type variables+```haskell+data ProductType a b = ProductType + { aField :: a+ , bField :: b + }+getShwifty ''ProductType+```++```swift+struct ProductType<A, B> {+ let aField: A+ let bField: B+}+```++#### A newtype+```haskell+newtype Newtype a = Newtype { getNewtype :: a }+getShwifty ''Newtype+```++```swift+struct Newtype<A> {+ let getNewtype: A+}+```++#### A type with a function field+```haskell+newtype Endo a = Endo { appEndo :: a -> a }+getShwifty ''Endo+```++```swift+struct Endo<A> {+ let appEndo: ((A) -> A)+}+```++#### A weird type with nested fields. Also note the Result's types being flipped from that of the Either.+```haskell+data YouveGotProblems a b = YouveGotProblems + { field1 :: Maybe (Maybe (Maybe a))+ , field2 :: Either (Maybe a) (Maybe b) + }+getShwifty ''YouveGotProblems+```++```swift+struct YouveGotProblems<A, B> {+ let field1: A???+ let field2: Result<B?, A?>+}+```++#### A type with polykinded type variables+```haskell+data PolyKinded (a :: k) = PolyKinded+getShwifty ''PolyKinded+```++```swift+struct PolyKinded<A> { }+```++#### A sum type where constructors might be records+```haskell+data SumType a b (c :: k) + = Sum1 Int a (Maybe b) + | Sum2 b + | Sum3 { x :: Int, y :: Int }+getShwifty ''SumType+```++```swift+enum SumType<A, B, C> {+ case field1(Int, A, B?)+ case field2(B)+ case field3(_ x: Int, _ y: Int)+}+```++#### A type containing another type with instance generated by 'getShwifty'+```haskell+newtype MyFirstType a = MyFirstType { getMyFirstType :: a }+getShwifty ''MyFirstType++data Contains a = Contains + { x :: MyFirstType Int+ , y :: MyFirstType a + }+getShwifty ''Contains+```++```swift+struct MyFirstType<A> {+ let getMyFirstType: A+}++struct Contains<A> {+ let x: MyFirstType<Int>+ let y: MyFirstType<A>+}+```
+ shwifty.cabal view
@@ -0,0 +1,59 @@+cabal-version: 2.2+name:+ shwifty+version:+ 0.0.1.0+synopsis:+ Generate swift types from haskell types.+description:+ Shwifty provides many utilities for generating swift types from haskell types,+ with great flexibility in representation, and emphasis on generating typesafe+ Swift code. Most of the types representable in Haskell98 are supported.+bug-reports:+ https://github.com/chessai/shwifty/issues+license:+ MIT+license-file:+ LICENSE+author:+ chessai+maintainer:+ chessai <chessai1996@gmail.com>+copyright:+ Copyright (c) 2020, chessai+category:+ Codegen, Text, TemplateHaskell+build-type:+ Simple+extra-source-files:+ CHANGELOG.md+ README.md++library+ hs-source-dirs:+ src+ exposed-modules:+ Shwifty+ --Test+ build-depends:+ , base >= 4.11 && < 4.14+ , bytestring >= 0.10 && < 0.11+ , case-insensitive >= 1.2 && < 1.3+ , containers >= 0.5.9 && < 0.7+ , mtl >= 2.2 && < 2.3+ , primitive >= 0.7 && < 0.8+ , template-haskell >= 2.11 && < 2.17+ , text >= 1.2 && < 1.3+ , th-abstraction >= 0.3 && < 0.4+ , time >= 1.8 && < 1.10+ , unordered-containers >= 0.2 && < 0.3+ , uuid-types >= 1.0 && < 1.1+ , vector >= 0.12 && < 0.13+ default-language:+ Haskell2010++source-repository head+ type:+ git+ location:+ git://github.com/chessai/shwifty.git
+ src/Shwifty.hs view
@@ -0,0 +1,2181 @@+{-# language+ AllowAmbiguousTypes+ , BangPatterns+ , CPP+ , DataKinds+ , DefaultSignatures+ , DeriveFoldable+ , DeriveFunctor+ , DeriveGeneric+ , DeriveLift+ , DeriveTraversable+ , DerivingStrategies+ , DuplicateRecordFields+ , FlexibleInstances+ , GADTs+ , KindSignatures+ , LambdaCase+ , MultiWayIf+ , NamedFieldPuns+ , OverloadedStrings+ , PolyKinds+ , RecordWildCards+ , ScopedTypeVariables+ , TemplateHaskell+ , TypeApplications+ , ViewPatterns+#-}++{-# options_ghc+ -Wall+ -fno-warn-duplicate-exports+#-}++-- | The Shwifty library allows generation of+-- Swift types (structs and enums) from Haskell+-- ADTs, using Template Haskell. The main+-- entry point to the library should be the+-- documentation and examples of 'getShwifty'.+-- See also 'getShwiftyWith'+-- and 'getShwiftyWithTags'.+--+-- This library is in alpha and there are a number+-- of known bugs which shouldn't affect most users.+-- See the issue tracker to see what those are.+--+-- There are probably many bugs/some weird behaviour+-- when it comes to data families. Please report+-- any issues on the issue tracker.+module Shwifty+ ( -- * Classes for conversion+ ToSwift(..)+ , ToSwiftData(..)++ -- * Generating instances+ , getShwifty+ , getShwiftyWith+ , getShwiftyWithTags++ -- * Types+ , Ty(..)+ , SwiftData(..)+ , Protocol(..)++ -- * Options for encoding types+ -- ** Option type+ , Options+ -- ** Actual Options+ , fieldLabelModifier+ , constructorModifier+ , optionalExpand+ , indent+ , generateToSwift+ , generateToSwiftData+ , dataProtocols+ , dataRawValue+ , typeAlias+ , newtypeTag+ , lowerFirstCase+ , lowerFirstField+ -- ** Default 'Options'+ , defaultOptions++ -- * Pretty-printing+ -- ** Functions+ , prettyTy+ , prettySwiftData+ -- ** Re-exports+ , X+ ) where++#include "MachDeps.h"++import Control.Monad.Except+import Data.CaseInsensitive (CI)+import Data.Foldable (foldlM,foldr',foldl')+import Data.Functor ((<&>))+import Data.Int (Int8,Int16,Int32,Int64)+import Data.List (intercalate)+import Data.List.NonEmpty ((<|), NonEmpty(..))+import Data.Maybe (mapMaybe, catMaybes)+import Data.Proxy (Proxy(..))+import Data.Time (UTCTime)+import Data.UUID.Types (UUID)+import Data.Vector (Vector)+import Data.Void (Void)+import Data.Word (Word8,Word16,Word32,Word64)+import GHC.Generics (Generic)+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import Language.Haskell.TH hiding (stringE)+import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Syntax (Lift)+import Prelude hiding (Enum(..))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import qualified Data.Primitive as Prim++-- | An AST representing a Swift type.+data Ty+ = Unit+ -- ^ Unit (called "Unit/Void" in swift). Empty struct type.+ | Bool+ -- ^ Bool+ | Character+ -- ^ Character+ | Str+ -- ^ String. Named 'Str' to avoid conflicts with+ -- 'Data.Aeson.String'.+ | I+ -- ^ signed machine integer+ | I8+ -- ^ signed 8-bit integer+ | I16+ -- ^ signed 16-bit integer+ | I32+ -- ^ signed 32-bit integer+ | I64+ -- ^ signed 64-bit integer+ | U+ -- ^ unsigned machine integer+ | U8+ -- ^ unsigned 8-bit integer+ | U16+ -- ^ unsigned 16-bit integer+ | U32+ -- ^ unsigned 32-bit integer+ | U64+ -- ^ unsigned 64-bit integer+ | F32+ -- ^ 32-bit floating point+ | F64+ -- ^ 64-bit floating point+ | Decimal+ -- ^ Increased-precision floating point+ | BigSInt32+ -- ^ 32-bit big integer+ | BigSInt64+ -- ^ 64-bit big integer+ | Tuple2 Ty Ty+ -- ^ 2-tuple+ | Tuple3 Ty Ty Ty+ -- ^ 3-tuple+ | Optional Ty+ -- ^ Maybe type+ | Result Ty Ty+ -- ^ Either type+ --+ -- /Note/: The error type in Swift must+ -- implement the @Error@ protocol. This library+ -- currently does not enforce this.+ | Set Ty+ -- ^ Set type+ | Dictionary Ty Ty+ -- ^ Dictionary type+ | Array Ty+ -- ^ array type+ | App Ty Ty+ -- ^ function type+ | Poly String+ -- ^ polymorphic type variable+ | Concrete+ { name :: String+ -- ^ the name of the type+ , tyVars :: [Ty]+ -- ^ the type's type variables+ }+ -- ^ a concrete type variable, and its+ -- type variables. Will typically be generated+ -- by 'getShwifty'.+ | Tag+ { name :: String+ -- ^ the name of the type+ , parent :: String+ -- ^ the type constructor of the type+ -- to which this alias belongs+ , typ :: Ty+ -- ^ the type that this represents+ , disambiguate :: Bool+ -- ^ does the type need disambiguation?+ --+ -- This will happen if there are multiple+ -- tags with the same type. This is needed+ -- to maintain safety.+ }+ -- ^ A @Tagged@ typealias, for newtyping+ -- in a way that doesn't break Codable.+ --+ -- See 'getShwiftyWithTags' for examples.+ deriving stock (Eq, Show, Read)+ deriving stock (Generic)+ deriving stock (Lift)++-- | A Swift datatype, either a struct (product type)+-- or enum (sum type). Haskll types are+-- sums-of-products, so the way we differentiate+-- when doing codegen,+-- is that types with a single constructor+-- will be converted to a struct, and those with+-- two or more constructors will be converted to an+-- enum. Types with 0 constructors will be converted+-- to an empty enum.+--+-- /Note/: There seems to be a haddock bug related+-- to `-XDuplicateRecordFields` which+-- causes the haddocks for the fields of 'SwiftEnum'+-- to refer to struct.+data SwiftData+ = SwiftStruct+ { name :: String+ -- ^ The name of the struct+ , tyVars :: [String]+ -- ^ The struct's type variables+ , protocols :: [Protocol]+ -- ^ The protocols which the struct+ -- implements+ , fields :: [(String, Ty)]+ -- ^ The fields of the struct. the pair+ -- is interpreted as (name, type).+ , tags :: [Ty]+ -- ^ The tags of the struct. See 'Tag'.+ }+ -- ^ A struct (product type)+ | SwiftEnum+ { name :: String+ -- ^ The name of the enum+ , tyVars :: [String]+ -- ^ The enum's type variables+ , protocols :: [Protocol]+ -- ^ The protocols which the enum+ -- implements+ , cases :: [(String, [(Maybe String, Ty)])]+ -- ^ The cases of the enum. the type+ -- can be interpreted as+ -- (name, [(label, type)]).+ , rawValue :: Maybe Ty+ -- ^ The rawValue of an enum. See+ -- https://developer.apple.com/documentation/swift/rawrepresentable/1540698-rawvalue+ --+ -- Typically the 'Ty' will be+ -- 'I' or 'String'.+ --+ -- /Note/: Currently, nothing will prevent+ -- you from putting something+ -- nonsensical here.+ , tags :: [Ty]+ -- ^ The tags of the struct. See 'Tag'.+ }+ -- ^ An enum (sum type)+ | TypeAlias+ { name :: String+ -- ^ the name of the type alias+ , tyVars :: [String]+ -- ^ the type variables of the type alias+ , typ :: Ty+ -- ^ the type this represents (RHS)+ }+ -- ^ A /top-level/ type alias+ deriving stock (Eq, Read, Show, Generic)++-- | The class for things which can be converted to+-- 'SwiftData'.+--+-- Typically the instance will be generated by+-- 'getShwifty'.+class ToSwiftData a where+ -- | Convert a type to 'SwiftData'+ toSwiftData :: Proxy a -> SwiftData+ -- | Pretty-print a type as its 'SwiftData'.+ prettySwiftData :: Proxy a -> String+ default prettySwiftData :: Proxy a -> String+ prettySwiftData = prettySwiftDataWith (indent defaultOptions) . toSwiftData++-- | Swift protocols.+-- Only a few are supported right now.+data Protocol+ = Hashable+ -- ^ The 'Hashable' protocol.+ -- See https://developer.apple.com/documentation/swift/hashable+ | Codable+ -- ^ The 'Codable' protocol.+ -- See https://developer.apple.com/documentation/swift/hashable+ | Equatable+ -- ^ The 'Equatable' protocol.+ -- See https://developer.apple.com/documentation/swift/hashable+ deriving stock (Eq, Read, Show, Generic)+ deriving stock (Lift)++-- | Options that specify how to+-- encode your 'SwiftData' to a swift type.+--+-- Options can be set using record syntax on+-- 'defaultOptions' with the fields below.+data Options = Options+ { typeConstructorModifier :: String -> String+ -- ^ Function applied to type constructor names.+ -- The default ('id') makes no changes.+ , fieldLabelModifier :: String -> String+ -- ^ Function applied to field labels.+ -- Handy for removing common record prefixes,+ -- for example. The default ('id') makes no+ -- changes.+ , constructorModifier :: String -> String+ -- ^ Function applied to value constructor names.+ -- The default ('id') makes no changes.+ , optionalExpand :: Bool+ -- ^ Whether or not to truncate Optional types.+ -- Normally, an Optional ('Maybe') is encoded+ -- as "A?", which is syntactic sugar for+ -- "Optional\<A\>". The default value ('False')+ -- will keep it as sugar. A value of 'True'+ -- will expand it to be desugared.+ , indent :: Int+ -- ^ Number of spaces to indent field names+ -- and cases. The default is 4.+ , generateToSwift :: Bool+ -- ^ Whether or not to generate a 'ToSwift'+ -- instance. Sometime this can be desirable+ -- if you want to define the instance by hand,+ -- or the instance exists elsewhere.+ -- The default is 'True', i.e., to generate+ -- the instance.+ , generateToSwiftData :: Bool+ -- ^ Whether or not to generate a 'ToSwiftData'+ -- instance. Sometime this can be desirable+ -- if you want to define the instance by hand,+ -- or the instance exists elsewhere.+ -- The default is 'True', i.e., to generate+ -- the instance.+ , dataProtocols :: [Protocol]+ -- ^ Protocols to add to a type.+ -- The default (@[]@) will add none.+ , dataRawValue :: Maybe Ty+ -- ^ The rawValue of an enum. See+ -- https://developer.apple.com/documentation/swift/rawrepresentable/1540698-rawvalue+ --+ -- The default ('Nothing') will not+ -- include any rawValue.+ --+ -- Typically, if the type does have+ -- a 'rawValue', the 'Ty' will be+ -- 'I' or 'Str'.+ --+ -- /Note/: Currently, nothing will prevent+ -- you from putting something+ -- nonsensical here.+ , typeAlias :: Bool+ -- ^ Whether or not to generate a newtype as+ -- a type alias. Consider if you want this+ -- or to use 'getShwiftyWithTags' instead.+ --+ -- The default ('False') will generate newtypes+ -- as their own structs.+ , newtypeTag :: Bool+ -- ^ Whether or not to generate a newtype as an+ -- empty enum with a tag. This is for type+ -- safety reasons, but with retaining the+ -- ability to have Codable conformance.+ --+ -- The default ('False') will not do this.+ --+ -- /Note/: This takes priority over 'typeAlias'.+ --+ -- /Note/: This option is not currently+ -- supported for newtype instances.+ --+ -- === __Examples__+ --+ -- > newtype NonEmptyText = MkNonEmptyText String+ -- > $(getShwiftyWith (defaultOptions { newtypeTag = True }) ''NonEmpyText)+ --+ -- @+ -- enum NonEmptyTextTag {+ -- typealias NonEmptyText = Tagged\<NonEmptyTextTag, String\>+ -- }+ -- @+ , lowerFirstField :: Bool+ -- ^ Whether or not to lower-case the first+ -- character of a field after applying all+ -- modifiers to it.+ --+ -- The default ('True') will do so.+ , lowerFirstCase :: Bool+ -- ^ Whether or not to lower-case the first+ -- character of a case after applying all+ -- modifiers to it.+ --+ -- The default ('True') will do so.+ }++-- | The default 'Options'.+--+-- @+-- defaultOptions :: Options+-- defaultOptions = Options+-- { typeConstructorModifier = id+-- , fieldLabelModifier = id+-- , constructorModifier = id+-- , optionalExpand= False+-- , indent = 4+-- , generateToSwift = True+-- , generateToSwiftData = True+-- , dataProtocols = []+-- , dataRawValue = Nothing+-- , typeAlias = False+-- , newtypeTag = False+-- , lowerFirstField = True+-- , lowerFirstCase = True+-- }+-- @+--+defaultOptions :: Options+defaultOptions = Options+ { typeConstructorModifier = id+ , fieldLabelModifier = id+ , constructorModifier = id+ , optionalExpand = False+ , indent = 4+ , generateToSwift = True+ , generateToSwiftData = True+ , dataProtocols = []+ , dataRawValue = Nothing+ , typeAlias = False+ , newtypeTag = False+ , lowerFirstField = True+ , lowerFirstCase = True+ }++-- | The class for things which can be converted to+-- a Swift type ('Ty').+--+-- Typically the instance will be generated by+-- 'getShwifty'.+class ToSwift a where+ toSwift :: Proxy a -> Ty++-- Used internally to reflect polymorphic type+-- variables into TH, then reify them into 'Poly'.+--+-- See the Rose tree section below+data SingSymbol (x :: Symbol)+instance KnownSymbol x => ToSwift (SingSymbol x) where+ toSwift _ = Poly (symbolVal (Proxy @x))++-- | A filler type to be used when pretty-printing.+-- The codegen used by shwifty doesn't look at+-- at what a type's type variables are instantiated+-- to, but rather at the type's top-level+-- definition. However,+-- to make GHC happy, you will have to fill in type+-- variables with unused types. To get around this,+-- you could also use something like+-- `-XQuantifiedConstraints`, or existential types,+-- but we leave that to the user to handle.+type X = Void++instance ToSwift Void where+ toSwift = const (Concrete "Void" [])++instance ToSwift () where+ toSwift = const Unit++instance ToSwift Bool where+ toSwift = const Bool++instance ToSwift UUID where+ toSwift = const (Concrete "UUID" [])++instance ToSwift UTCTime where+ toSwift = const (Concrete "Date" [])++instance forall a b. (ToSwift a, ToSwift b) => ToSwift (a -> b) where+ toSwift = const (App (toSwift (Proxy @a)) (toSwift (Proxy @b)))++instance forall a. ToSwift a => ToSwift (Maybe a) where+ toSwift = const (Optional (toSwift (Proxy @a)))++-- | /Note/: In Swift, the ordering of the type+-- variables is flipped - Shwifty has made the+-- design choice to flip them for you. If you+-- take issue with this, please open an issue+-- for discussion on GitHub.+instance forall a b. (ToSwift a, ToSwift b) => ToSwift (Either a b) where+ toSwift = const (Result (toSwift (Proxy @b)) (toSwift (Proxy @a)))++instance ToSwift Integer where+ toSwift = const+#if WORD_SIZE_IN_BITS == 32+ BigSInt32+#else+ BigSInt64+#endif++instance ToSwift Int where toSwift = const I+instance ToSwift Int8 where toSwift = const I8+instance ToSwift Int16 where toSwift = const I16+instance ToSwift Int32 where toSwift = const I32+instance ToSwift Int64 where toSwift = const I64++instance ToSwift Word where toSwift = const U+instance ToSwift Word8 where toSwift = const U8+instance ToSwift Word16 where toSwift = const U16+instance ToSwift Word32 where toSwift = const U32+instance ToSwift Word64 where toSwift = const U64++instance ToSwift Float where toSwift = const F32+instance ToSwift Double where toSwift = const F64++instance ToSwift Char where toSwift = const Character++instance forall a. (ToSwift a) => ToSwift (Prim.Array a) where+ toSwift = const (Array (toSwift (Proxy @a)))++instance forall a. (ToSwift a) => ToSwift (Prim.SmallArray a) where+ toSwift = const (Array (toSwift (Proxy @a)))++instance ToSwift Prim.ByteArray where+ toSwift = const (Array U8)++instance forall a. (ToSwift a) => ToSwift (Prim.PrimArray a) where+ toSwift = const (Array (toSwift (Proxy @a)))++instance forall a. ToSwift a => ToSwift (Vector a) where+ toSwift = const (Array (toSwift (Proxy @a)))++instance {-# overlappable #-} forall a. ToSwift a => ToSwift [a] where+ toSwift = const (Array (toSwift (Proxy @a)))++instance {-# overlapping #-} ToSwift [Char] where toSwift = const Str++instance ToSwift TL.Text where toSwift = const Str+instance ToSwift TS.Text where toSwift = const Str++instance ToSwift BL.ByteString where toSwift = const (Array U8)+instance ToSwift BS.ByteString where toSwift = const (Array U8)++instance ToSwift (CI s) where toSwift = const Str++instance forall k v. (ToSwift k, ToSwift v) => ToSwift (M.Map k v) where toSwift = const (Dictionary (toSwift (Proxy @k)) (toSwift (Proxy @v)))++instance forall k v. (ToSwift k, ToSwift v) => ToSwift (HM.HashMap k v) where toSwift = const (Dictionary (toSwift (Proxy @k)) (toSwift (Proxy @v)))++instance forall a b. (ToSwift a, ToSwift b) => ToSwift ((,) a b) where+ toSwift = const (Tuple2 (toSwift (Proxy @a)) (toSwift (Proxy @b)))++instance forall a b c. (ToSwift a, ToSwift b, ToSwift c) => ToSwift ((,,) a b c) where+ toSwift = const (Tuple3 (toSwift (Proxy @a)) (toSwift (Proxy @b)) (toSwift (Proxy @c)))++labelCase :: Maybe String -> Ty -> String+labelCase Nothing ty = prettyTy ty+labelCase (Just label) ty = "_ " ++ label ++ ": " ++ prettyTy ty++prettyTypeHeader :: String -> [String] -> String+prettyTypeHeader name [] = name+prettyTypeHeader name tyVars = name ++ "<" ++ intercalate ", " tyVars ++ ">"++-- | Pretty-print a 'Ty'.+prettyTy :: Ty -> String+prettyTy = \case+ Str -> "String"+ Unit -> "()"+ Bool -> "Bool"+ Character -> "Character"+ Tuple2 e1 e2 -> "(" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ")"+ Tuple3 e1 e2 e3 -> "(" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ", " ++ prettyTy e3 ++ ")"+ Optional e -> prettyTy e ++ "?"+ Result e1 e2 -> "Result<" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ">"+ Set e -> "Set<" ++ prettyTy e ++ ">"+ Dictionary e1 e2 -> "Dictionary<" ++ prettyTy e1 ++ ", " ++ prettyTy e2 ++ ">"+ Array e -> "[" ++ prettyTy e ++ "]"+ -- App is special, we recurse until we no longer+ -- any applications.+ App e1 e2 -> prettyApp e1 e2+ I -> "Int"+ I8 -> "Int8"+ I16 -> "Int16"+ I32 -> "Int32"+ I64 -> "Int64"+ U -> "UInt"+ U8 -> "UInt8"+ U16 -> "UInt16"+ U32 -> "UInt32"+ U64 -> "UInt64"+ F32 -> "Float"+ F64 -> "Double"+ Decimal -> "Decimal"+ BigSInt32 -> "BigSInt32"+ BigSInt64 -> "BigSInt64"+ Poly ty -> ty+ Concrete ty [] -> ty+ Concrete ty tys -> ty+ ++ "<"+ ++ intercalate ", " (map prettyTy tys)+ ++ ">"+ Tag {name,parent} -> parent ++ "." ++ name++prettyApp :: Ty -> Ty -> String+prettyApp t1 t2 = "(("+ ++ intercalate ", " (map prettyTy as)+ ++ ") -> "+ ++ prettyTy r+ ++ ")"+ where+ (as, r) = go t1 t2+ go e1 (App e2 e3) = case go e2 e3 of+ (args, ret) -> (e1 : args, ret)+ go e1 e2 = ([e1], e2)++prettyRawValueAndProtocols :: Maybe Ty -> [Protocol] -> String+prettyRawValueAndProtocols Nothing ps = prettyProtocols ps+prettyRawValueAndProtocols (Just ty) [] = ": " ++ prettyTy ty+prettyRawValueAndProtocols (Just ty) ps = ": " ++ prettyTy ty ++ ", " ++ intercalate ", " (map show ps)++prettyProtocols :: [Protocol] -> String+prettyProtocols = \case+ [] -> ""+ ps -> ": " ++ intercalate ", " (map show ps)++prettyTags :: String -> [Ty] -> String+prettyTags indents = go where+ go [] = ""+ go (Tag{name,parent,typ,disambiguate}:ts) = []+ ++ "\n"+ ++ prettyTagDisambiguator disambiguate indents name+ ++ indents+ ++ "typealias "+ ++ name+ ++ " = Tagged<"+ ++ (if disambiguate then name ++ "Tag" else parent)+ ++ ", "+ ++ prettyTy typ+ ++ ">"+ ++ go ts+ go _ = error "non-tag supplied to prettyTags"++prettyTagDisambiguator :: ()+ => Bool+ -- ^ disambiguate?+ -> String+ -- ^ indents+ -> String+ -- ^ parent type name+ -> String+prettyTagDisambiguator disambiguate indents parent+ = if disambiguate+ then []+ ++ indents+ ++ "enum "+ ++ parent+ ++ "Tag { }\n"+ else ""++-- | Pretty-print a 'SwiftData'.+-- This function cares about indent.+prettySwiftDataWith :: ()+ => Int -- ^ indent+ -> SwiftData+ -> String+prettySwiftDataWith indent = \case++ SwiftEnum {name,tyVars,protocols,cases,rawValue,tags} -> []+ ++ "enum "+ ++ prettyTypeHeader name tyVars+ ++ prettyRawValueAndProtocols rawValue protocols+ ++ " {"+ ++ newlineNonEmpty cases+ ++ go cases+ ++ prettyTags indents tags+ ++ newlineNonEmpty tags+ ++ "}"+ where+ go [] = ""+ go ((caseNm, []):xs) = []+ ++ indents+ ++ "case "+ ++ caseNm+ ++ "\n"+ ++ go xs+ go ((caseNm, cs):xs) = []+ ++ indents+ ++ "case "+ ++ caseNm+ ++ "("+ ++ (intercalate ", " (map (uncurry labelCase) cs))+ ++ ")\n"+ ++ go xs+ SwiftStruct {name,tyVars,protocols,fields,tags} -> []+ ++ "struct "+ ++ prettyTypeHeader name tyVars+ ++ prettyProtocols protocols+ ++ " {"+ ++ newlineNonEmpty fields+ ++ go fields+ ++ prettyTags indents tags+ ++ newlineNonEmpty tags+ ++ "}"+ where+ go [] = ""+ go ((fieldName,ty):fs) = indents ++ "let " ++ fieldName ++ ": " ++ prettyTy ty ++ "\n" ++ go fs+ TypeAlias {name, tyVars, typ} -> []+ ++ "typealias "+ ++ prettyTypeHeader name tyVars+ ++ " = "+ ++ prettyTy typ+ where+ indents = replicate indent ' '++ newlineNonEmpty [] = ""+ newlineNonEmpty _ = "\n"++ensureEnabled :: Extension -> ShwiftyM ()+ensureEnabled ext = do+ enabled <- lift $ isExtEnabled ext+ unless enabled $ do+ throwError $ ExtensionNotEnabled ext++-- | Generate 'ToSwiftData' and 'ToSwift' instances+-- for your type. 'ToSwift' instances are typically+-- used to build cases or fields, whereas+-- 'ToSwiftData' instances are for building structs+-- and enums. Click the @Examples@ button to see+-- examples of what Swift gets generated in+-- different scenarios. To get access to the+-- generated code, you will have to use one of+-- the pretty-printing functions provided.+--+-- === __Examples__+--+-- > -- A simple sum type+-- > data SumType = Sum1 | Sum2 | Sum3+-- > getShwifty ''SumType+--+-- @+-- enum SumType {+-- case sum1+-- case sum2+-- case sum3+-- }+-- @+--+-- > -- A simple product type+-- > data ProductType = ProductType { x :: Int, y :: Int }+-- > getShwifty ''ProductType+--+-- @+-- struct ProductType {+-- let x: Int+-- let y: Int+-- }+-- @+--+-- > -- A sum type with type variables+-- > data SumType a b = SumL a | SumR b+-- > getShwifty ''SumType+--+-- @+-- enum SumType\<A, B\> {+-- case sumL(A)+-- case sumR(B)+-- }+-- @+--+-- > -- A product type with type variables+-- > data ProductType a b = ProductType { aField :: a, bField :: b }+-- > getShwifty ''ProductType+--+-- @+-- struct ProductType\<A, B\> {+-- let aField: A+-- let bField: B+-- }+-- @+--+-- > -- A newtype+-- > newtype Newtype a = Newtype { getNewtype :: a }+-- > getShwifty ''Newtype+--+-- @+-- struct Newtype\<A\> {+-- let getNewtype: A+-- }+-- @+--+-- > -- A type with a function field+-- > newtype Endo a = Endo { appEndo :: a -> a }+-- > getShwifty ''Endo+--+-- @+-- struct Endo\<A\> {+-- let appEndo: ((A) -> A)+-- }+-- @+--+-- > -- A type with a kookier function field+-- > newtype Fun a = Fun { fun :: Int -> Char -> Bool -> String -> Maybe a }+-- > getShwifty ''Fun+--+-- @+-- struct Fun<A> {+-- let fun: ((Int, Char, Bool, String) -> A?)+-- }+-- @+--+-- > -- A weird type with nested fields. Also note the Result's types being flipped from that of the Either.+-- > data YouveGotProblems a b = YouveGotProblems { field1 :: Maybe (Maybe (Maybe a)), field2 :: Either (Maybe a) (Maybe b) }+-- > getShwifty ''YouveGotProblems+--+-- @+-- struct YouveGotProblems\<A, B\> {+-- let field1: Option\<Option\<Option\<A\>\>\>+-- let field2: Result\<Option\<B\>,Option\<A\>\>+-- }+-- @+--+-- > -- A type with polykinded type variables+-- > -- Also note that there is no newline because+-- > -- of the absence of fields+-- > data PolyKinded (a :: k) = PolyKinded+-- > getShwifty ''PolyKinded+--+-- @+-- struct PolyKinded\<A\> { }+-- @+--+-- > -- A sum type where constructors might be records+-- > data SumType a b (c :: k) = Sum1 Int a (Maybe b) | Sum2 b | Sum3 { x :: Int, y :: Int }+-- > getShwifty ''SumType+--+-- @+-- enum SumType\<A, B, C\> {+-- case field1(Int, A, Optional\<B\>)+-- case field2(B)+-- case field3(_ x: Int, _ y: Int)+-- }+-- @+--+-- > -- A type containing another type with instance generated by 'getShwifty'+-- > newtype MyFirstType a = MyFirstType { getMyFirstType :: a }+-- > getShwifty ''MyFirstType+-- >+-- > data Contains a = Contains { x :: MyFirstType Int, y :: MyFirstType a }+-- > getShwifty ''Contains+--+-- @+-- struct MyFirstType\<A\> {+-- let getMyFirstType: A+-- }+--+-- struct Contains\<A\> {+-- let x: MyFirstType\<Int\>+-- let y: MyFirstType\<A\>+-- }+-- @+getShwifty :: Name -> Q [Dec]+getShwifty = getShwiftyWith defaultOptions++-- | Like 'getShwifty', but lets you supply+-- your own 'Options'. Click the examples+-- for some clarification of what you can do.+--+-- === __Examples__+--+-- > data PrefixedFields = MkPrefixedFields { prefixedFieldsX :: Int, prefixedFieldsY :: Int }+-- > $(getShwiftyWith (defaultOptions { fieldLabelModifier = drop (length "PrefixedFields") }) ''PrefixedFields)+--+-- @+-- struct PrefixedFields {+-- let x: Int+-- let y: Int+-- }+-- @+--+-- > data PrefixedCons = MkPrefixedConsLeft | MkPrefixedConsRight+-- > $(getShwiftyWith (defaultOptions { constructorModifier = drop (length "MkPrefixedCons"), dataProtocols = [Codable] }) ''PrefixedCons)+--+-- @+-- enum PrefixedCons: Codable {+-- case left+-- case right+-- }+-- @+getShwiftyWith :: Options -> Name -> Q [Dec]+getShwiftyWith o n = getShwiftyWithTags o [] n++data NewtypeInfo = NewtypeInfo+ { newtypeName :: Name+ -- ^ Type constructor+ , newtypeVars :: [TyVarBndr]+ -- ^ Type parameters+ , newtypeInstTypes :: [Type]+ -- ^ Argument types+ , newtypeVariant :: DatatypeVariant+ -- ^ Whether or not the type is a+ -- newtype or newtype instance+ , newtypeCon :: ConstructorInfo+ }++reifyNewtype :: Name -> ShwiftyM NewtypeInfo+reifyNewtype n = do+ DatatypeInfo{..} <- lift $ reifyDatatype n+ case datatypeCons of+ [c] -> do+ pure NewtypeInfo {+ newtypeName = datatypeName+ , newtypeVars = datatypeVars+ , newtypeInstTypes = datatypeInstTypes+ , newtypeVariant = datatypeVariant+ , newtypeCon = c+ }+ _ -> do+ throwError $ NotANewtype n++-- Generate the tags for a type.+-- Also generate the ToSwift instance for each tag+-- type. We can't just expect people to do this+-- with a separate 'getShwifty' call, because+-- they will generate the wrong code, since other+-- types with a tag that isn't theirs won't generate+-- well-scoped fields.+getTags :: ()+ => Name+ -- ^ name of parent type+ -> [Name]+ -- ^ tags+ -> ShwiftyM ([Exp], [Dec])+getTags parentName ts = do+ let len = length ts+ disambiguate <- lift $ [||len > 1||]+ tags <- foldlM+ (\(es,ds) n -> do++ NewtypeInfo{..} <- reifyNewtype n+ let ConstructorInfo{..} = newtypeCon++ -- generate the tag+ let tyconName = case newtypeVariant of+ NewtypeInstance -> constructorName+ _ -> newtypeName+ typ <- case constructorFields of+ [ty] -> pure ty+ _ -> throwError $ NotANewtype newtypeName+ let tag = RecConE 'Tag+ [ (mkName "name", unqualName tyconName)+ , (mkName "parent", unqualName parentName)+ , (mkName "typ", toSwiftEPoly typ)+ , (mkName "disambiguate", unType disambiguate)+ ]++ -- generate the instance+ !instHeadTy+ <- buildTypeInstance newtypeName ClassSwift newtypeInstTypes newtypeVars newtypeVariant+ -- we do not want to strip here+ clauseTy <- tagToSwift tyconName typ parentName+ swiftTyInst <- lift $ instanceD+ (pure [])+ (pure instHeadTy)+ [ funD 'toSwift+ [ clause [] (normalB (pure clauseTy)) []+ ]+ ]++ pure $ (es ++ [tag], ds ++ [swiftTyInst])+ ) ([], []) ts+ pure tags++getToSwift :: ()+ => Options+ -- ^ options+ -> Name+ -- ^ type name+ -> [Type]+ -- ^ type variables+ -> [TyVarBndr]+ -- ^ type binders+ -> DatatypeVariant+ -- ^ type variant+ -> [ConstructorInfo]+ -- ^ constructors+ -> ShwiftyM [Dec]+getToSwift Options{..} parentName instTys tyVarBndrs variant cons = if generateToSwift+ then do+ instHead <- buildTypeInstance parentName ClassSwift instTys tyVarBndrs variant+ clauseTy <- case variant of+ NewtypeInstance -> case cons of+ [ConstructorInfo{..}] -> do+ newtypToSwift constructorName instTys+ _ -> do+ throwError ExpectedNewtypeInstance+ _ -> do+ typToSwift newtypeTag parentName instTys+ inst <- lift $ instanceD+ (pure [])+ (pure instHead)+ [ funD 'toSwift+ [ clause [] (normalB (pure clauseTy)) []+ ]+ ]+ pure [inst]+ else do+ pure []++getToSwiftData :: ()+ => Options+ -- ^ options+ -> Name+ -- ^ type name+ -> [Type]+ -- ^ type variables+ -> [TyVarBndr]+ -- ^ type binders+ -> DatatypeVariant+ -- ^ type variant+ -> [Exp]+ -- ^ tags+ -> [ConstructorInfo]+ -- ^ constructors+ -> ShwiftyM [Dec]+getToSwiftData o@Options{..} parentName instTys tyVarBndrs variant tags cons = if generateToSwiftData+ then do+ instHead <- buildTypeInstance parentName ClassSwiftData instTys tyVarBndrs variant+ clauseData <- consToSwift o parentName instTys variant tags cons+ clausePretty <- mkClausePretty o+ inst <- lift $ instanceD+ (pure [])+ (pure instHead)+ [ funD 'toSwiftData+ [ clause [] (normalB (pure clauseData)) []+ ]+ , funD 'prettySwiftData+ [ clause [] (normalB (pure clausePretty)) []+ ]+ ]+ pure [inst]+ else do+ pure []++-- | Like 'getShwiftyWith', but lets you supply+-- tags. Tags are type-safe typealiases that+-- are akin to newtypes in Haskell. The+-- introduction of a struct around something+-- which is, say, a UUID in Swift means that+-- the default Codable instance will not work+-- correctly. So we introduce a tag(s). See the+-- examples to see how this looks. Also, see+-- https://github.com/pointfreeco/swift-tagged,+-- the library which these tags use. The library+-- is not included in any generated code.+--+-- === __Examples__+--+-- > -- Example of using the swift-tagged library:+-- > -- A type containing a database key+-- > data User = User { id :: UserId, name :: Text }+-- > -- the user key+-- > newtype UserId = UserId UUID+-- > $(getShwiftyWithTags defaultOptions [ ''UserId ] ''User)+-- > -- A type that also contains the UserId+-- > data UserDetails = UserDetails { id :: UserId, lastName :: Text }+-- > getShwifty ''UserDetails+--+-- @+-- struct User {+-- let id: UserId+-- let name: String+--+-- typealias UserId = Tagged\<User,UUID\>+-- }+--+-- struct UserDetails {+-- let id: User.UserId+-- let lastName: String+-- }+-- @+--+-- > -- Example type with multiple tags+-- > newtype Name = MkName String+-- > newtype Email = MkEmail String+-- > data Person = Person { name :: Name, email :: Email }+-- > $(getShwiftyWithTags defaultOptions [ ''Name, ''Email ] ''Person)+--+-- @+-- struct Person {+-- let name: Name+-- let email: Email+--+-- enum NameTag {}+-- typealias Name = Tagged\<NameTag, String\>+--+-- enum EmailTag {}+-- typealias Email = Tagged\<EmailTag, String\>+-- }+-- @+getShwiftyWithTags :: ()+ => Options+ -> [Name]+ -> Name+ -> Q [Dec]+getShwiftyWithTags o@Options{..} ts name = do+ r <- runExceptT $ do+ ensureEnabled ScopedTypeVariables+ ensureEnabled DataKinds+ ensureEnabled DuplicateRecordFields+ DatatypeInfo+ { datatypeName = parentName+ , datatypeVars = tyVarBndrs+ , datatypeInstTypes = instTys+ , datatypeVariant = variant+ , datatypeCons = cons+ } <- lift $ reifyDatatype name+ noExistentials cons++ -- get tags/ToSwift instances for tags+ (tags, extraDecs) <- getTags parentName ts++ swiftDataInst <- getToSwiftData o parentName instTys tyVarBndrs variant tags cons++ swiftTyInst <- getToSwift o parentName instTys tyVarBndrs variant cons+ pure $ swiftDataInst ++ swiftTyInst ++ extraDecs+ case r of+ Left e -> fail $ prettyShwiftyError e+ Right d -> pure d++noExistentials :: [ConstructorInfo] -> ShwiftyM ()+noExistentials cs = forM_ cs $ \ConstructorInfo{..} ->+ case (constructorName, constructorVars) of+ (_, []) -> do+ pure ()+ (cn, cvs) -> do+ throwError $ ExistentialTypes cn cvs++data ShwiftyError+ = SingleConNonRecord+ { _conName :: Name+ }+ | EncounteredInfixConstructor+ { _conName :: Name+ }+ | KindVariableCannotBeRealised+ { _typName :: Name+ , _kind :: Kind+ }+ | ExtensionNotEnabled+ { _ext :: Extension+ }+ | ExistentialTypes+ { _conName :: Name+ , _types :: [TyVarBndr]+ }+ | ExpectedNewtypeInstance+ | NotANewtype+ { _typName :: Name+ }++prettyShwiftyError :: ShwiftyError -> String+prettyShwiftyError = \case+ SingleConNonRecord (nameStr -> n) -> mempty+ ++ n+ ++ ": Cannot get shwifty with single-constructor "+ ++ "non-record types. This is due to a "+ ++ "restriction of Swift that prohibits structs "+ ++ "from not having named fields. Try turning "+ ++ n ++ " into a record!"+ EncounteredInfixConstructor (nameStr -> n) -> mempty+ ++ n+ ++ ": Cannot get shwifty with infix constructors. "+ ++ "Swift doesn't support them. Try changing "+ ++ n ++ " into a prefix constructor!"+ KindVariableCannotBeRealised (nameStr -> n) typ ->+ let (typStr, kindStr) = prettyKindVar typ+ in mempty+ ++ n+ ++ ": Encountered a type variable ("+ ++ typStr+ ++ ") with a kind ("+ ++ kindStr+ ++ ") that can't "+ ++ "get shwifty! Shwifty needs to be able "+ ++ "to realise your kind variables to `*`, "+ ++ "since that's all that makes sense in "+ ++ "Swift. The only kinds that can happen with "+ ++ "are `*` and the free-est kind, `k`."+ ExtensionNotEnabled ext -> mempty+ ++ show ext+ ++ " is not enabled. Shwifty needs it to work!"+ -- TODO: make this not print out implicit kinds.+ -- e.g. for `data Ex = forall x. Ex x`, there are+ -- no implicit `TyVarBndr`s, but for+ -- `data Ex = forall x y z. Ex x`, there are two:+ -- the kinds inferred by `y` and `z` are both `k`.+ -- We print these out - this could be confusing to+ -- the end user. I'm not immediately certain how to+ -- be rid of them.+ ExistentialTypes (nameStr -> n) tys -> mempty+ ++ n+ ++ " has existential type variables ("+ ++ L.intercalate ", " (map prettyTyVarBndrStr tys)+ ++ ")! Shwifty doesn't support these."+ ExpectedNewtypeInstance -> mempty+ ++ "Expected a newtype instance. This is an "+ ++ "internal logic error. Please report it as a "+ ++ "bug."+ NotANewtype (nameStr -> n) -> mempty+ ++ n+ ++ " is not a newtype. This is an internal logic "+ ++ "error. Please report it as a bug."++prettyTyVarBndrStr :: TyVarBndr -> String+prettyTyVarBndrStr = \case+ PlainTV n -> go n+ KindedTV n _ -> go n+ where+ go = TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show++-- prettify the type and kind.+prettyKindVar :: Type -> (String, String)+prettyKindVar = \case+ SigT typ k -> (go typ, go k)+ VarT n -> (nameStr n, "*")+ typ -> error $ "Shwifty.prettyKindVar: used on a type without a kind signature. Type was: " ++ show typ+ where+ go = TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show . ppr++type ShwiftyM = ExceptT ShwiftyError Q++tagToSwift :: ()+ => Name+ -- ^ name of the type constructor+ -> Type+ -- ^ type variables+ -> Name+ -- ^ parent name+ -> ShwiftyM Exp+tagToSwift tyconName typ parentName = do+ -- TODO: use '_' instead of matching+ value <- lift $ newName "value"+ matches <- lift $ fmap ((:[]) . pure) $ do+ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'Tag+ $ [ (mkName "name", unqualName tyconName)+ , (mkName "parent", unqualName parentName)+ , (mkName "typ", toSwiftECxt typ)+ , (mkName "disambiguate", (ConE 'False))+ ]+ )+ []+ lift $ lamE [varP value] (caseE (varE value) matches)+newtypToSwift :: ()+ => Name+ -- ^ name of the constructor+ -> [Type]+ -- ^ type variables+ -> ShwiftyM Exp+newtypToSwift conName (stripConT -> instTys) = do+ typToSwift False conName instTys++typToSwift :: ()+ => Bool+ -- ^ is this a newtype tag?+ -> Name+ -- ^ name of the type+ -> [Type]+ -- ^ type variables+ -> ShwiftyM Exp+typToSwift newtypeTag parentName instTys = do+ -- TODO: use '_' instead of matching+ value <- lift $ newName "value"+ let tyVars = map toSwiftECxt instTys+ let name =+ let parentStr = nameStr parentName+ accessedName = if newtypeTag+ then parentStr ++ "Tag." ++ parentStr+ else parentStr+ in stringE accessedName+ matches <- lift $ fmap ((:[]) . pure) $ do+ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'Concrete+ $ [ (mkName "name", name)+ , (mkName "tyVars", ListE tyVars)+ ]+ )+ []+ lift $ lamE [varP value] (caseE (varE value) matches)++rawValueE :: Maybe Ty -> Exp+rawValueE = \case+ Nothing -> ConE 'Nothing+ Just ty -> AppE (ConE 'Just) (ParensE (tyE ty))++-- god this is annoying. write a cleaner+-- version of this+tyE :: Ty -> Exp+tyE = \case+ Unit -> ConE 'Unit+ Bool -> ConE 'Bool+ Character -> ConE 'Character+ Str -> ConE 'Str+ I -> ConE 'I+ I8 -> ConE 'I8+ I16 -> ConE 'I16+ I32 -> ConE 'I32+ I64 -> ConE 'I64+ U -> ConE 'U+ U8 -> ConE 'U8+ U16 -> ConE 'U16+ U32 -> ConE 'U32+ U64 -> ConE 'U64+ F32 -> ConE 'F32+ F64 -> ConE 'F64+ Decimal -> ConE 'Decimal+ BigSInt32 -> ConE 'BigSInt32+ BigSInt64 -> ConE 'BigSInt64+ Poly s -> AppE (ConE 'Poly) (stringE s)+ Concrete tyCon tyVars -> AppE (AppE (ConE 'Concrete) (stringE tyCon)) (ListE (map tyE tyVars))+ Tuple2 e1 e2 -> AppE (AppE (ConE 'Tuple2) (tyE e1)) (tyE e2)+ Tuple3 e1 e2 e3 -> AppE (AppE (AppE (ConE 'Tuple3) (tyE e1)) (tyE e2)) (tyE e3)+ Optional e -> AppE (ConE 'Optional) (tyE e)+ Result e1 e2 -> AppE (AppE (ConE 'Result) (tyE e1)) (tyE e2)+ Set e -> AppE (ConE 'Set) (tyE e)+ Dictionary e1 e2 -> AppE (AppE (ConE 'Dictionary) (tyE e1)) (tyE e2)+ App e1 e2 -> AppE (AppE (ConE 'App) (tyE e1)) (tyE e2)+ Array e -> AppE (ConE 'Array) (tyE e)+ Tag{name,parent,typ,disambiguate} -> AppE (AppE (AppE (AppE (ConE 'Tag) (stringE name)) (stringE parent)) (tyE typ)) (if disambiguate then ConE 'True else ConE 'False)++mkClausePretty :: ()+ => Options+ -> ShwiftyM Exp+mkClausePretty Options{..} = do+ value <- lift $ newName "value"+ matches <- lift $ do+ x <- match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ AppE+ (AppE+ (VarE 'prettySwiftDataWith)+ (LitE (IntegerL (fromIntegral indent)))+ )+ $ ParensE+ (AppE+ (VarE 'toSwiftData)+ (VarE value)+ )+ )+ []+ pure [pure x]+ lift $ lamE [varP value] (caseE (varE value) matches)++consToSwift :: ()+ => Options+ -- ^ options about how to encode things+ -> Name+ -- ^ name of type+ -> [Type]+ -- ^ type variables+ -> DatatypeVariant+ -- ^ data type variant+ -> [Exp]+ -- ^ tags+ -> [ConstructorInfo]+ -- ^ constructors+ -> ShwiftyM Exp+consToSwift o@Options{..} parentName instTys variant ts = \case+ [] -> do+ value <- lift $ newName "value"+ matches <- liftCons (mkVoid parentName instTys ts)+ lift $ lamE [varP value] (caseE (varE value) matches)+ cons -> do+ -- TODO: use '_' instead of matching+ value <- lift $ newName "value"+ matches <- matchesWorker+ lift $ lamE [varP value] (caseE (varE value) matches)+ where+ -- bad name+ matchesWorker :: ShwiftyM [Q Match]+ matchesWorker = case cons of+ [con] -> liftCons $ do+ case variant of+ NewtypeInstance -> do+ if | typeAlias -> do+ mkNewtypeInstanceAlias instTys con+ | otherwise -> do+ mkNewtypeInstance o instTys ts con+ Newtype -> do+ if | newtypeTag -> do+ mkTypeTag o parentName instTys con+ | typeAlias -> do+ mkTypeAlias parentName instTys con+ | otherwise -> do+ mkProd o parentName instTys ts con+ _ -> do+ mkProd o parentName instTys ts con+ _ -> do+ let tyVars = prettyTyVars instTys+ let protos = map (ConE . mkName . show) dataProtocols+ let raw = rawValueE dataRawValue+ let tags = ListE ts+ cases <- forM cons (liftEither . mkCase o)+ pure $ (:[]) $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'SwiftEnum+ $ [ (mkName "name", unqualName parentName)+ , (mkName "tyVars", tyVars)+ , (mkName "protocols", ListE protos)+ , (mkName "cases", ListE cases)+ , (mkName "rawValue", raw)+ , (mkName "tags", tags)+ ]+ )+ []++liftCons :: (Functor f, Applicative g) => f a -> f ([g a])+liftCons x = ((:[]) . pure) <$> x++-- Create the case (String, [(Maybe String, Ty)])+mkCaseHelper :: Options -> Name -> [Exp] -> Exp+mkCaseHelper o name es = TupE [ caseName o name, ListE es ]++mkCase :: ()+ => Options+ -> ConstructorInfo+ -> Either ShwiftyError Exp+mkCase o = \case+ -- non-record+ ConstructorInfo+ { constructorVariant = NormalConstructor+ , constructorName = name+ , constructorFields = fields+ , ..+ } -> Right $ mkCaseHelper o name $ fields <&>+ (\typ -> TupE+ [ ConE 'Nothing+ , toSwiftEPoly typ+ ]+ )+ ConstructorInfo+ { constructorVariant = InfixConstructor+ , constructorName = name+ , ..+ } -> Left $ EncounteredInfixConstructor name+ -- records+ -- we turn names into labels+ ConstructorInfo+ { constructorVariant = RecordConstructor fieldNames+ , constructorName = name+ , constructorFields = fields+ , ..+ } ->+ let cases = zipWith (caseField o) fieldNames fields+ in Right $ mkCaseHelper o name cases++caseField :: Options -> Name -> Type -> Exp+caseField o n typ = TupE+ [ mkLabel o n+ , toSwiftEPoly typ+ ]++onHeadWith :: Bool -> String -> String+onHeadWith toLower = if toLower+ then onHead Char.toLower+ else id++-- apply a function only to the head of a string+onHead :: (Char -> Char) -> String -> String+onHead f = \case { [] -> []; (x:xs) -> f x : xs }++mkLabel :: Options -> Name -> Exp+mkLabel Options{..} = AppE (ConE 'Just)+ . stringE+ . fieldLabelModifier+ . onHeadWith lowerFirstField+ . TS.unpack+ . last+ . TS.splitOn "."+ . TS.pack+ . show++mkNewtypeInstanceAlias :: ()+ => [Type]+ -- ^ type variables+ -> ConstructorInfo+ -- ^ constructor info+ -> ShwiftyM Match+mkNewtypeInstanceAlias (stripConT -> instTys) = \case+ ConstructorInfo+ { constructorFields = [field]+ , ..+ } -> do+ let tyVars = prettyTyVars instTys+ lift $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'TypeAlias+ $ [ (mkName "name", unqualName constructorName)+ , (mkName "tyVars", tyVars)+ , (mkName "typ", toSwiftECxt field)+ ]+ )+ []+ _ -> throwError $ ExpectedNewtypeInstance++mkNewtypeInstance :: ()+ => Options+ -- ^ encoding options+ -> [Type]+ -- ^ type variables+ -> [Exp]+ -- ^ tags+ -> ConstructorInfo+ -- ^ constructor info+ -> ShwiftyM Match+mkNewtypeInstance o@Options{dataProtocols} (stripConT -> instTys) ts = \case+ ConstructorInfo+ { constructorVariant = RecordConstructor [fieldName]+ , constructorFields = [field]+ , ..+ } -> do+ let tyVars = prettyTyVars instTys+ let protos = ListE $ map (ConE . mkName . show) dataProtocols+ let fields = ListE $ [prettyField o fieldName field]+ let tags = ListE ts+ lift $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'SwiftStruct+ $ [ (mkName "name", unqualName constructorName)+ , (mkName "tyVars", tyVars)+ , (mkName "protocols", protos)+ , (mkName "fields", fields)+ , (mkName "tags", tags)+ ]+ )+ []+ _ -> throwError ExpectedNewtypeInstance++-- make a newtype into an empty enum+-- with a tag+mkTypeTag :: ()+ => Options+ -- ^ options+ -> Name+ -- ^ type name+ -> [Type]+ -- ^ type variables+ -> ConstructorInfo+ -- ^ constructor info+ -> ShwiftyM Match+mkTypeTag Options{..} typName instTys = \case+ ConstructorInfo+ { constructorFields = [field]+ , ..+ } -> do+ let tyVars = prettyTyVars instTys+ let protos = map (ConE . mkName . show) dataProtocols+ let raw = rawValueE dataRawValue+ let parentName = nameStr typName ++ "Tag"+ let tag = RecConE 'Tag+ [ (mkName "name", unqualName typName)+ , (mkName "parent", stringE parentName)+ , (mkName "typ", toSwiftEPoly field)+ , (mkName "disambiguate", ConE 'False)+ ]+ lift $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'SwiftEnum+ $ [ (mkName "name", stringE parentName)+ , (mkName "tyVars", tyVars)+ , (mkName "protocols", ListE protos)+ , (mkName "cases", ListE [])+ , (mkName "rawValue", raw)+ , (mkName "tags", ListE [tag])+ ]+ )+ []+ _ -> throwError $ NotANewtype typName++-- make a newtype into a type alias+mkTypeAlias :: ()+ => Name+ -- ^ type name+ -> [Type]+ -- ^ type variables+ -> ConstructorInfo+ -- ^ constructor info+ -> ShwiftyM Match+mkTypeAlias typName instTys = \case+ ConstructorInfo+ { constructorFields = [field]+ , ..+ } -> do+ let tyVars = prettyTyVars instTys+ lift $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'TypeAlias+ $ [ (mkName "name", unqualName typName)+ , (mkName "tyVars", tyVars)+ , (mkName "typ", toSwiftECxt field)+ ]+ )+ []+ _ -> throwError $ NotANewtype typName++-- | Make a void type (empty enum)+mkVoid :: ()+ => Name+ -- ^ type name+ -> [Type]+ -- ^ type variables+ -> [Exp]+ -- ^ tags+ -> ShwiftyM Match+mkVoid typName instTys ts = do+ let tyVars = prettyTyVars instTys+ lift $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'SwiftEnum+ $ [ (mkName "name", unqualName typName)+ , (mkName "tyVars", tyVars)+ , (mkName "protocols", ListE [])+ , (mkName "cases", ListE [])+ , (mkName "rawValue", ConE 'Nothing)+ , (mkName "tags", ListE ts)+ ]+ )+ []++-- | Make a single-constructor product (struct)+mkProd :: ()+ => Options+ -- ^ encoding options+ -> Name+ -- ^ type name+ -> [Type]+ -- ^ type variables+ -> [Exp]+ -- ^ tags+ -> ConstructorInfo+ -- ^ constructor info+ -> ShwiftyM Match+mkProd o@Options{dataProtocols} typName instTys ts = \case+ -- single constructor, no fields+ ConstructorInfo+ { constructorVariant = NormalConstructor+ , constructorFields = []+ , ..+ } -> do+ let tyVars = prettyTyVars instTys+ let protos = map (ConE . mkName . show) dataProtocols+ let tags = ListE ts+ lift $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'SwiftStruct+ $ [ (mkName "name", unqualName typName)+ , (mkName "tyVars", tyVars)+ , (mkName "protocols", ListE protos)+ , (mkName "fields", ListE [])+ , (mkName "tags", tags)+ ]+ )+ []+ -- single constructor, non-record (Normal)+ ConstructorInfo+ { constructorVariant = NormalConstructor+ , constructorName = name+ } -> do+ throwError $ SingleConNonRecord name+ -- single constructor, non-record (Infix)+ ConstructorInfo+ { constructorVariant = InfixConstructor+ , constructorName = name+ } -> do+ throwError $ EncounteredInfixConstructor name+ -- single constructor, record+ ConstructorInfo+ { constructorVariant = RecordConstructor fieldNames+ , ..+ } -> do+ let tyVars = prettyTyVars instTys+ let protos = map (ConE . mkName . show) dataProtocols+ let fields = ListE $ zipWith (prettyField o) fieldNames constructorFields+ let tags = ListE ts+ lift $ match+ (conP 'Proxy [])+ (normalB+ $ pure+ $ RecConE 'SwiftStruct+ $ [ (mkName "name", unqualName typName)+ , (mkName "tyVars", tyVars)+ , (mkName "protocols", ListE protos)+ , (mkName "fields", fields)+ , (mkName "tags", tags)+ ]+ )+ []++-- turn a field name into a swift case name.+-- examples:+--+-- data Foo = A | B | C+-- =>+-- enum Foo {+-- case a+-- case b+-- case c+-- }+--+-- data Bar a = MkBar1 a | MkBar2+-- =>+-- enum Bar<A> {+-- case mkBar1(A)+-- case mkBar2+-- }+caseName :: Options -> Name -> Exp+caseName Options{..} = id+ . stringE+ . onHeadWith lowerFirstCase+ . constructorModifier+ . TS.unpack+ . last+ . TS.splitOn "."+ . TS.pack+ . show++-- remove qualifiers from a name, turn into String+nameStr :: Name -> String+nameStr = TS.unpack . last . TS.splitOn "." . TS.pack . show++-- remove qualifiers from a name, turn into Exp+unqualName :: Name -> Exp+unqualName = stringE . nameStr++-- prettify a type variable as an Exp+prettyTyVar :: Name -> Exp+prettyTyVar = stringE . map Char.toUpper . TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show++-- prettify a bunch of type variables as an Exp+prettyTyVars :: [Type] -> Exp+prettyTyVars = ListE . map prettyTyVar . getTyVars++-- get the free type variables from many types+getTyVars :: [Type] -> [Name]+getTyVars = mapMaybe getFreeTyVar++-- get the free type variables in a type+getFreeTyVar :: Type -> Maybe Name+getFreeTyVar = \case+ VarT name -> Just name+ SigT (VarT name) _kind -> Just name+ _ -> Nothing++-- make a struct field pretty+prettyField :: Options -> Name -> Type -> Exp+prettyField Options{..} name ty = TupE+ [ (stringE (onHeadWith lowerFirstField (fieldLabelModifier (nameStr name))))+ , toSwiftEPoly ty+ ]++-- build the instance head for a type+buildTypeInstance :: ()+ => Name+ -- ^ name of the type+ -> ShwiftyClass+ -- ^ which class instance head we are building+ -> [Type]+ -- ^ type variables+ -> [TyVarBndr]+ -- ^ the binders for our tyvars+ -> DatatypeVariant+ -- ^ variant (datatype, newtype, data family, newtype family)+ -> ShwiftyM Type+buildTypeInstance tyConName cls varTysOrig tyVarBndrs variant = do+ -- Make sure to expand through type/kind synonyms!+ -- Otherwise, the eta-reduction check might get+ -- tripped up over type variables in a synonym+ -- that are actually dropped.+ -- (See GHC Trac #11416 for a scenario where this+ -- actually happened)+ varTysExp <- lift $ mapM resolveTypeSynonyms varTysOrig++ -- get the kind status of all of our types.+ -- we must realise them all to *.+ starKindStats :: [KindStatus] <- foldlM+ (\stats k -> case canRealiseKindStar k of+ NotKindStar -> do+ throwError $ KindVariableCannotBeRealised tyConName k+ s -> pure (stats ++ [s])+ ) [] varTysExp++ let -- get the names of our kind vars+ kindVarNames :: [Name]+ kindVarNames = flip mapMaybe starKindStats+ (\case+ IsKindVar n -> Just n+ _ -> Nothing+ )++ let+ -- instantiate polykinded things to star.+ varTysExpSubst :: [Type]+ varTysExpSubst = map (substNamesWithKindStar kindVarNames) varTysExp++ -- the constraints needed on type variables+ preds :: [Maybe Pred]+ preds = map (deriveConstraint cls) varTysExpSubst++ -- We now sub all of the specialised-to-* kind+ -- variable names with *, but in the original types,+ -- not the synonym-expanded types. The reason we+ -- do this is superficial: we want the derived+ -- instance to resemble the datatype written in+ -- source code as closely as possible. For example,+ --+ -- data family Fam a+ -- newtype instance Fam String = Fam String+ --+ -- We'd want to generate the instance:+ --+ -- instance C (Fam String)+ --+ -- Not:+ --+ -- instance C (Fam [Char])+ varTysOrigSubst :: [Type]+ varTysOrigSubst =+ map (substNamesWithKindStar kindVarNames) $ varTysOrig++ -- if we are working on a data family+ -- or newtype family, we need to peel off+ -- the kinds. See Note [Kind signatures in+ -- derived instances]+ varTysOrigSubst' :: [Type]+ varTysOrigSubst' = if isDataFamily variant+ then varTysOrigSubst+ else map unSigT varTysOrigSubst++ -- the constraints needed on type variables+ -- makes up the constraint part of the+ -- instance head.+ instanceCxt :: Cxt+ instanceCxt = catMaybes preds++ -- the class and type in the instance head.+ instanceType :: Type+ instanceType = AppT (ConT (shwiftyClassName cls))+ $ applyTyCon tyConName varTysOrigSubst'++ -- forall <tys>. ctx tys => Cls ty+ lift $ forallT+ (map tyVarBndrNoSig tyVarBndrs)+ (pure instanceCxt)+ (pure instanceType)++-- the class we're generating an instance of+data ShwiftyClass+ = ClassSwift -- ToSwift+ | ClassSwiftData -- ToSwiftData++-- turn a 'ShwiftyClass' into a 'Name'+shwiftyClassName :: ShwiftyClass -> Name+shwiftyClassName = \case+ ClassSwift -> ''ToSwift+ ClassSwiftData -> ''ToSwiftData++-- derive the constraint needed on a type variable+-- in order to build the instance head for a class.+deriveConstraint :: ()+ => ShwiftyClass+ -- ^ class name+ -> Type+ -- ^ type+ -> Maybe Pred+ -- ^ constraint on type+deriveConstraint c@ClassSwift typ+ | not (isTyVar typ) = Nothing+ | hasKindStar typ = Just (applyCon (shwiftyClassName c) tName)+ | otherwise = Nothing+ where+ tName :: Name+ tName = varTToName typ+ varTToName = \case+ VarT n -> n+ SigT t _ -> varTToName t+ _ -> error "Shwifty.varTToName: encountered non-type variable"+deriveConstraint ClassSwiftData _ = Nothing++-- apply a type constructor to a type variable.+-- this can be useful for letting the kind+-- inference engine doing work for you. see+-- 'toSwiftECxt' for an example of this.+applyCon :: Name -> Name -> Pred+applyCon con t = AppT (ConT con) (VarT t)++-- peel off a kind signature from a Type+unSigT :: Type -> Type+unSigT = \case+ SigT t _ -> t+ t -> t++-- is the type a type variable?+isTyVar :: Type -> Bool+isTyVar = \case+ VarT _ -> True+ SigT t _ -> isTyVar t+ _ -> False++-- does the type have kind *?+hasKindStar :: Type -> Bool+hasKindStar = \case+ VarT _ -> True+ SigT _ StarT -> True+ _ -> False++-- perform the substitution of type variables+-- who have kinds which can be realised to *,+-- with the same type variable where its kind+-- has been turned into *+substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns+ where+ substNameWithKind :: Name -> Kind -> Type -> Type+ substNameWithKind n k = applySubstitution (M.singleton n k)++-- | The status of a kind variable w.r.t. its+-- ability to be realised into *.+data KindStatus+ = KindStar+ -- ^ kind * (or some k which can be realised to *)+ | NotKindStar+ -- ^ any other kind+ | IsKindVar Name+ -- ^ is actually a kind variable+ | IsCon Name+ -- ^ is a constructor - this will typically+ -- happen in a data family instance, because+ -- we often have to construct a+ -- FlexibleInstance. our old check for+ -- canRealiseKindStar didn't check for+ -- `ConT` - where this would happen.+ --+ -- TODO: Now i think this might need to be+ -- removed in favour of something smarter.++-- can we realise the type's kind to *?+canRealiseKindStar :: Type -> KindStatus+canRealiseKindStar = \case+ VarT{} -> KindStar+ SigT _ StarT -> KindStar+ SigT _ (VarT n) -> IsKindVar n+ ConT n -> IsCon n+ _ -> NotKindStar++-- discard the kind signature from a TyVarBndr.+tyVarBndrNoSig :: TyVarBndr -> TyVarBndr+tyVarBndrNoSig = \case+ PlainTV n -> PlainTV n+ KindedTV n _k -> PlainTV n++-- fully applies a type constructor to its+-- type variables+applyTyCon :: Name -> [Type] -> Type+applyTyCon = foldl' AppT . ConT++-- Turn a String into an Exp string literal+stringE :: String -> Exp+stringE = LitE . StringL++-- convert a type into a 'Ty'.+-- we respect constraints here - e.g. in+-- `(Swift a, Swift b) => Swift (Foo a b)`,+-- we don't just fill in holes like in+-- `toSwiftEPoly`, we actually turn `a`+-- and `b` into `Ty`s directly. Consequently,+-- the implementation is much simpler - just+-- an application.+--+-- Note the use of unSigT - see Note+-- [Kind signatures in derived instances].+toSwiftECxt :: Type -> Exp+toSwiftECxt (unSigT -> typ) = AppE+ (VarE 'toSwift)+ (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ))++-- convert a type into a 'Ty'.+-- polymorphic types do not require a 'ToSwift'+-- instance, since we fill them in with 'SingSymbol'.+--+-- We do this by stretching out a type along its+-- spine, completely. we then fill in any polymorphic+-- variables with 'SingSymbol', reflecting the type+-- Name to a Symbol. then we compress the spine to+-- get the original type. the 'ToSwift' instance for+-- 'SingSymbol' gets us where we need to go.+--+-- Note that @compress . decompress@ is not+-- actually equivalent to the identity function on+-- Type because of ForallT, where we discard some+-- context. However, for any types we care about,+-- there shouldn't be a ForallT, so this *should*+-- be fine.+toSwiftEPoly :: Type -> Exp+toSwiftEPoly = \case+ -- we don't need to special case VarT and SigT+ VarT n+ -> AppE (ConE 'Poly) (prettyTyVar n)+ SigT (VarT n) _+ -> AppE (ConE 'Poly) (prettyTyVar n)+ typ ->+ let decompressed = decompress typ+ prettyName = map Char.toUpper . TS.unpack . head . TS.splitOn "_" . last . TS.splitOn "." . TS.pack . show+ filledInHoles = decompressed <&>+ (\case+ VarT name -> AppT+ (ConT ''Shwifty.SingSymbol)+ (LitT (StrTyLit (prettyName name)))+ SigT (VarT name) _ -> AppT+ (ConT ''Shwifty.SingSymbol)+ (LitT (StrTyLit (prettyName name)))+ t -> t+ )+ typ' = compress filledInHoles+ in AppE+ (VarE 'toSwift)+ (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ'))++decompress :: Type -> Rose Type+decompress typ = case unapplyTy typ of+ tyCon :| tyArgs -> Rose tyCon (decompress <$> tyArgs)++compress :: Rose Type -> Type+compress (Rose typ []) = typ+compress (Rose t ts) = foldl' AppT t (compress <$> ts)++unapplyTy :: Type -> NonEmpty Type+unapplyTy = NE.reverse . go+ where+ go = \case+ AppT t1 t2 -> t2 <| go t1+ SigT t _ -> go t+ ForallT _ _ t -> go t+ t -> t :| []++-- | Types can be stretched out into a Rose tree.+-- decompress will stretch a type out completely,+-- in such a way that it cannot be stretched out+-- further. compress will reconstruct a type from+-- its stretched form.+--+-- Also note that this is equivalent to+-- Cofree NonEmpty Type.+--+-- Examples:+--+-- Maybe a+-- =>+-- AppT (ConT Maybe) (VarT a)+--+--+-- Either a b+-- =>+-- AppT (AppT (ConT Either) (VarT a)) (VarT b)+-- =>+-- Rose (ConT Either)+-- [ Rose (VarT a)+-- [+-- ]+-- , Rose (VarT b)+-- [+-- ]+-- ]+--+--+-- Either (Maybe a) (Maybe b)+-- =>+-- AppT (AppT (ConT Either) (AppT (ConT Maybe) (VarT a))) (AppT (ConT Maybe) (VarT b))+-- =>+-- Rose (ConT Either)+-- [ Rose (ConT Maybe)+-- [ Rose (VarT a)+-- [+-- ]+-- ]+-- , Rose (ConT Maybe)+-- [ Rose (VarT b)+-- [+-- ]+-- ]+-- ]+data Rose a = Rose a [Rose a]+ deriving stock (Eq, Show)+ deriving stock (Functor,Foldable,Traversable)++{-+Note [Kind signatures in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is possible to put explicit kind signatures into the derived instances, e.g.,++ instance C a => C (Data (f :: * -> *)) where ...++But it is preferable to avoid this if possible. If we come up with an incorrect+kind signature (which is entirely possible, since Template Haskell doesn't always+have the best track record with reifying kind signatures), then GHC will flat-out+reject the instance, which is quite unfortunate.++Plain old datatypes have the advantage that you can avoid using any kind signatures+at all in their instances. This is because a datatype declaration uses all type+variables, so the types that we use in a derived instance uniquely determine their+kinds. As long as we plug in the right types, the kind inferencer can do the rest+of the work. For this reason, we use unSigT to remove all kind signatures before+splicing in the instance context and head.++Data family instances are trickier, since a data family can have two instances that+are distinguished by kind alone, e.g.,++ data family Fam (a :: k)+ data instance Fam (a :: * -> *)+ data instance Fam (a :: *)++If we dropped the kind signatures for C (Fam a), then GHC will have no way of+knowing which instance we are talking about. To avoid this scenario, we always+include explicit kind signatures in data family instances. There is a chance that+the inferred kind signatures will be incorrect, in which case we have to write the instance manually.+-}++-- are we working on a data family+-- or newtype family?+isDataFamily :: DatatypeVariant -> Bool+isDataFamily = \case+ NewtypeInstance -> True+ DataInstance -> True+ _ -> False++stripConT :: [Type] -> [Type]+stripConT = mapMaybe noConT+ where+ noConT = \case+ ConT {} -> Nothing+ t -> Just t