elmental-0.1.0.0: test/Codegen/SampleTypes.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StarIsType #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}

module Codegen.SampleTypes where

import Data.Kind (Type)
import Data.Text (Text)
import Elmental
import Elmental.Generate (SomeStructure, include)
import GHC.TypeLits (Nat)
import Generics.Kind.TH (deriveGenericK, deriveGenericKQuiet)

data SimpleType = SimpleType Int

data SimpleRecord = SimpleRecord
    { name :: PolymorphicRecursiveType SimpleType
    , age :: SimpleType
    }

data EmptyAlias = EmptyAlias

data SimpleRecordAlias = SimpleRecordAlias
    { name :: PolymorphicRecursiveType SimpleType
    , age :: SimpleType
    }

data RecordWithMultipleConstructors
    = FirstRecordConstructor {foo :: Bool}
    | SecondRecordConstructor {bar :: Maybe Int}

data MonomorphicRecursiveType = SMRTNil | SMRTCons Int MonomorphicRecursiveType

data PolymorphicRecursiveType (a :: Type) = SPRTNil | SPRTCons a (PolymorphicRecursiveType a)

data SimpleHKT (f :: Type -> Type) = SimpleHKT (f String)

data HKTWithSpecializedKindStarParams a b f = HKTWithSpecializedKindStarParams b (f a)

data HKTWithUnspecializedParams (f :: Type -> Type) (a :: Type) (b :: Type)
    = HKTWithUnspecializedParams (f (f (f a))) b

data NatPhantomParameter (n :: Nat) a = NatPhantomParameter [a]

data Tag = Report | Submission

type family HKD (tag :: Tag) a where
    -- HKD 'Report ByteString64 = Bool
    HKD 'Report a = Maybe a
    HKD 'Submission (FileUpload 'Submission) = Maybe (FileUpload 'Submission)
    HKD 'Submission a = a

data FileUpload tag = FileUpload
    { fileName :: HKD tag Text
    -- , content :: HKD tag ByteString64
    }

data Form tag = Form
    { userName :: HKD tag Text
    , upload :: HKD tag (FileUpload tag)
    }

data LargeRecord a = LargeRecord
    { field0 :: NatPhantomParameter 0 a
    , field1 :: NatPhantomParameter 1 a
    , field2 :: NatPhantomParameter 2 a
    , field3 :: NatPhantomParameter 3 a
    , field4 :: NatPhantomParameter 4 a
    , field5 :: NatPhantomParameter 5 a
    , field6 :: NatPhantomParameter 6 a
    , field7 :: NatPhantomParameter 7 a
    , field8 :: NatPhantomParameter 8 a
    , field9 :: NatPhantomParameter 9 a
    , field10 :: NatPhantomParameter 10 a
    , field11 :: NatPhantomParameter 11 a
    , field12 :: NatPhantomParameter 12 a
    , field13 :: NatPhantomParameter 13 a
    , field14 :: NatPhantomParameter 14 a
    , field15 :: NatPhantomParameter 15 a
    , field16 :: NatPhantomParameter 16 a
    , field17 :: NatPhantomParameter 17 a
    , field18 :: NatPhantomParameter 18 a
    , field19 :: NatPhantomParameter 19 a
    , field20 :: NatPhantomParameter 20 a
    , field21 :: NatPhantomParameter 21 a
    , field22 :: NatPhantomParameter 22 a
    , field23 :: NatPhantomParameter 23 a
    , field24 :: NatPhantomParameter 24 a
    , field25 :: NatPhantomParameter 25 a
    , field26 :: NatPhantomParameter 26 a
    , field27 :: NatPhantomParameter 27 a
    , field28 :: NatPhantomParameter 28 a
    , field29 :: NatPhantomParameter 29 a
    , field30 :: NatPhantomParameter 30 a
    , field31 :: NatPhantomParameter 31 a
    , field32 :: NatPhantomParameter 32 a
    , field33 :: NatPhantomParameter 33 a
    , field34 :: NatPhantomParameter 34 a
    , field35 :: NatPhantomParameter 35 a
    , field36 :: NatPhantomParameter 36 a
    , field37 :: NatPhantomParameter 37 a
    , field38 :: NatPhantomParameter 38 a
    , field39 :: NatPhantomParameter 39 a
    , field40 :: NatPhantomParameter 40 a
    , field41 :: NatPhantomParameter 41 a
    , field42 :: NatPhantomParameter 42 a
    , field43 :: NatPhantomParameter 43 a
    , field44 :: NatPhantomParameter 44 a
    , field45 :: NatPhantomParameter 45 a
    , field46 :: NatPhantomParameter 46 a
    , field47 :: NatPhantomParameter 47 a
    , field48 :: NatPhantomParameter 48 a
    , field49 :: NatPhantomParameter 49 a
    , field50 :: NatPhantomParameter 50 a
    , field51 :: NatPhantomParameter 51 a
    , field52 :: NatPhantomParameter 52 a
    , field53 :: NatPhantomParameter 53 a
    , field54 :: NatPhantomParameter 54 a
    , field55 :: NatPhantomParameter 55 a
    , field56 :: NatPhantomParameter 56 a
    , field57 :: NatPhantomParameter 57 a
    , field58 :: NatPhantomParameter 58 a
    , field59 :: NatPhantomParameter 59 a
    , field60 :: NatPhantomParameter 60 a
    , field61 :: NatPhantomParameter 61 a
    , field62 :: NatPhantomParameter 62 a
    , field63 :: NatPhantomParameter 63 a
    , field64 :: NatPhantomParameter 64 a
    , field65 :: NatPhantomParameter 65 a
    , field66 :: NatPhantomParameter 66 a
    , field67 :: NatPhantomParameter 67 a
    , field68 :: NatPhantomParameter 68 a
    , field69 :: NatPhantomParameter 69 a
    , field70 :: NatPhantomParameter 70 a
    , field71 :: NatPhantomParameter 71 a
    , field72 :: NatPhantomParameter 72 a
    , field73 :: NatPhantomParameter 73 a
    , field74 :: NatPhantomParameter 74 a
    , field75 :: NatPhantomParameter 75 a
    , field76 :: NatPhantomParameter 76 a
    , field77 :: NatPhantomParameter 77 a
    , field78 :: NatPhantomParameter 78 a
    , field79 :: NatPhantomParameter 79 a
    , field80 :: NatPhantomParameter 80 a
    , field81 :: NatPhantomParameter 81 a
    , field82 :: NatPhantomParameter 82 a
    , field83 :: NatPhantomParameter 83 a
    , field84 :: NatPhantomParameter 84 a
    , field85 :: NatPhantomParameter 85 a
    , field86 :: NatPhantomParameter 86 a
    , field87 :: NatPhantomParameter 87 a
    , field88 :: NatPhantomParameter 88 a
    , field89 :: NatPhantomParameter 89 a
    , field90 :: NatPhantomParameter 90 a
    , field91 :: NatPhantomParameter 91 a
    , field92 :: NatPhantomParameter 92 a
    , field93 :: NatPhantomParameter 93 a
    , field94 :: NatPhantomParameter 94 a
    , field95 :: NatPhantomParameter 95 a
    , field96 :: NatPhantomParameter 96 a
    , field97 :: NatPhantomParameter 97 a
    , field98 :: NatPhantomParameter 98 a
    , field99 :: NatPhantomParameter 99 a
    }
data CountryCode
    = AD
    | AE
    | AF
    | AG
    | AI
    | AL
    | AM
    | AO
    | AQ
    | AR
    | AS
    | AT
    | AU
    | AW
    | AX
    | AZ
    | BA
    | BB
    | BD
    | BE
    | BF
    | BG
    | BH
    | BI
    | BJ
    | BL
    | BM
    | BN
    | BO
    | BQ
    | BR
    | BS
    | BT
    | BV
    | BW
    | BY
    | BZ
    | CA
    | CC
    | CD
    | CF
    | CG
    | CH
    | CI
    | CK
    | CL
    | CM
    | CN
    | CO
    | CR
    | CU
    | CV
    | CW
    | CX
    | CY
    | CZ
    | DE
    | DJ
    | DK
    | DM
    | DO
    | DZ
    | EC
    | EE
    | EG
    | EH
    | ER
    | ES
    | ET
    | FI
    | FJ
    | FK
    | FM
    | FO
    | FR
    | GA
    | GB
    | GD
    | GE
    | GF
    | GG
    | GH
    | GI
    | GL
    | GM
    | GN
    | GP
    | GQ
    | GR
    | GS
    | GT
    | GU
    | GW
    | GY
    | HK
    | HM
    | HN
    | HR
    | HT
    | HU
    | ID
    | IE
    | IL
    | IM
    | IN
    | IO
    | IQ
    | IR
    | IS
    | IT
    | JE
    | JM
    | JO
    | JP
    | KE
    | KG
    | KH
    | KI
    | KM
    | KN
    | KP
    | KR
    | KW
    | KY
    | KZ
    | LA
    | LB
    | LC
    | LI
    | LK
    | LR
    | LS
    | LT
    | LU
    | LV
    | LY
    | MA
    | MC
    | MD
    | ME
    | MF
    | MG
    | MH
    | MK
    | ML
    | MM
    | MN
    | MO
    | MP
    | MQ
    | MR
    | MS
    | MT
    | MU
    | MV
    | MW
    | MX
    | MY
    | MZ
    | NA
    | NC
    | NE
    | NF
    | NG
    | NI
    | NL
    | NO
    | NP
    | NR
    | NU
    | NZ
    | OM
    | PA
    | PE
    | PF
    | PG
    | PH
    | PK
    | PL
    | PM
    | PN
    | PR
    | PS
    | PT
    | PW
    | PY
    | QA
    | RE
    | RO
    | RS
    | RU
    | RW
    | SA
    | SB
    | SC
    | SD
    | SE
    | SG
    | SH
    | SI
    | SJ
    | SK
    | SL
    | SM
    | SN
    | SO
    | SR
    | SS
    | ST
    | SV
    | SX
    | SY
    | SZ
    | TC
    | TD
    | TF
    | TG
    | TH
    | TJ
    | TK
    | TL
    | TM
    | TN
    | TO
    | TR
    | TT
    | TV
    | TW
    | TZ
    | UA
    | UG
    | UM
    | US
    | UY
    | UZ
    | VA
    | VC
    | VE
    | VG
    | VI
    | VN
    | VU
    | WF
    | WS
    | YE
    | YT
    | ZA
    | ZM
    | ZW

$(deriveGenericK ''SimpleType)
$(deriveGenericK ''SimpleRecord)
$(deriveGenericK ''SimpleRecordAlias)
$(deriveGenericK ''EmptyAlias)
$(deriveGenericK ''RecordWithMultipleConstructors)
$(deriveGenericK ''MonomorphicRecursiveType)
$(deriveGenericK ''PolymorphicRecursiveType)
$(deriveGenericK ''SimpleHKT)
$(deriveGenericK ''HKTWithSpecializedKindStarParams)
$(deriveGenericK ''HKTWithUnspecializedParams)
$(deriveGenericK ''NatPhantomParameter)
$(deriveGenericK ''LargeRecord)
$(deriveGenericK ''CountryCode)
$(deriveGenericKQuiet ''FileUpload)
$(deriveGenericKQuiet ''Form)

-- Datatypes defined elsewhere

$(deriveGenericK ''Bool)
$(deriveGenericK ''Maybe)
$(deriveGenericK ''Either)

sampleTypes :: [SomeStructure]
sampleTypes =
    [ include @SimpleType
    , include @SimpleRecord
    , include @SimpleRecordAlias
    , include @EmptyAlias
    , include @MonomorphicRecursiveType
    , include @PolymorphicRecursiveType
    , include @(SimpleHKT Maybe)
    , include @(HKTWithSpecializedKindStarParams Int Text Maybe)
    , include @(HKTWithUnspecializedParams (Either Int))
    , include @(NatPhantomParameter 3)
    , include @RecordWithMultipleConstructors
    , include @LargeRecord
    , include @CountryCode
    , include @Either
    , include @(FileUpload 'Submission)
    , include @(FileUpload 'Report)
    , include @(Form 'Submission)
    , include @(Form 'Report)
    ]

instance ElmDeclarable SimpleType
instance ElmDeclarable SimpleRecord
instance ElmDeclarable RecordWithMultipleConstructors
instance ElmDeclarable MonomorphicRecursiveType
instance ElmDeclarable PolymorphicRecursiveType
instance (ElmDeclarable f, HasSymbolInfo f) => ElmDeclarable (SimpleHKT f) where
    mapTo =
        (defaultMapping @(SimpleHKT f))
            { typeName = "SimpleHKT" <> getTypeName @f
            }

instance ElmDeclarable (HKTWithSpecializedKindStarParams Int Text Maybe)
instance ElmDeclarable (HKTWithUnspecializedParams (Either Int))

instance ElmDeclarable (NatPhantomParameter n) where
    mapTo =
        (defaultMapping @(NatPhantomParameter n))
            { typeName = "LookMaNoPhantomParam"
            }

instance ElmDeclarable LargeRecord

instance ElmDeclarable Int where
    mapTo =
        ElmMapping
            { typeName = "Int"
            , moduleName = Nothing
            , decoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "int"
                        , symbolModuleName = "Json.Decode"
                        }
            , encoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "int"
                        , symbolModuleName = "Json.Encode"
                        }
            , args = []
            , isTypeAlias = False
            , urlPiece = Nothing
            , queryParam = Nothing
            }

instance ElmDeclarable Text where
    mapTo =
        ElmMapping
            { typeName = "String"
            , moduleName = Nothing
            , decoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "string"
                        , symbolModuleName = "Json.Decode"
                        }
            , encoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "string"
                        , symbolModuleName = "Json.Encode"
                        }
            , args = []
            , isTypeAlias = False
            , urlPiece = Nothing
            , queryParam = Nothing
            }

instance ElmDeclarable [Char] where
    mapTo = mapTo @Text

instance ElmDeclarable CountryCode where
    mapTo = setModule "Data.CountryCode" (defaultMapping @CountryCode)

instance ElmDeclarable Bool where
    mapTo =
        ElmMapping
            { typeName = "Bool"
            , moduleName = Nothing
            , decoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "bool"
                        , symbolModuleName = "Json.Decode"
                        }
            , encoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "bool"
                        , symbolModuleName = "Json.Encode"
                        }
            , args = []
            , isTypeAlias = False
            , urlPiece = Nothing
            , queryParam = Nothing
            }

instance ElmDeclarable Maybe where
    mapTo =
        ElmMapping
            { typeName = "Maybe"
            , moduleName = Just "Maybe"
            , decoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "nullable"
                        , symbolModuleName = "Json.Decode"
                        }
            , encoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "maybe"
                        , symbolModuleName = "Json.Encode.Extra"
                        }
            , args = []
            , isTypeAlias = False
            , urlPiece = Nothing
            , queryParam = Nothing
            }

instance ElmDeclarable Either where
    mapTo = setModule "Codegen.Either" (defaultMapping @Either)

instance ElmDeclarable [] where
    mapTo =
        ElmMapping
            { typeName = "List"
            , moduleName = Nothing
            , decoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "list"
                        , symbolModuleName = "Json.Decode"
                        }
            , encoderLocation =
                Just $
                    SymbolLocation
                        { symbolName = "list"
                        , symbolModuleName = "Json.Encode"
                        }
            , args = []
            , isTypeAlias = False
            , urlPiece = Nothing
            , queryParam = Nothing
            }

instance ElmDeclarable (Form 'Submission) where
    mapTo = setModule "Codegen.Submission" (defaultMapping @(Form 'Submission))

instance ElmDeclarable (Form 'Report) where
    mapTo = setModule "Codegen.Report" (defaultMapping @(Form 'Report))

instance ElmDeclarable (FileUpload 'Submission) where
    mapTo = setModule "Codegen.Submission" (defaultMapping @(FileUpload 'Submission))

instance ElmDeclarable (FileUpload 'Report) where
    mapTo = setModule "Codegen.Report" (defaultMapping @(FileUpload 'Report))

instance ElmDeclarable SimpleRecordAlias where
    mapTo =
        (defaultMapping @SimpleRecordAlias)
            { isTypeAlias = True
            }

instance ElmDeclarable EmptyAlias where
    mapTo =
        (defaultMapping @EmptyAlias)
            { isTypeAlias = True
            }