Holmusk/elm-street
1
1
Fork 0
mirror of https://github.com/Holmusk/elm-street.git synced 2024-11-20 18:52:47 +03:00
Code Issues Projects Releases Wiki Activity

Allow specifying custom code generation settings (#131)

Browse Source
This commit is contained in:
Jan Hrcek 2023-08-03 06:28:37 +02:00 committed by GitHub
parent e2569a3366
commit 609c5ec7d6
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 257 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@ -6,6 +6,7 @@ The changelog is available [on GitHub][2].
## Unreleased
* Add GHC 9.4.5 and 9.6.2 to CI / tested-with
* Introduce CodeGenOptions that allow customizing how record field names are modified.
## 0.2.0.0 - Mar 29, 2022

11
README.md
View File

@ -9,9 +9,8 @@ Crossing the road between Haskell and Elm.
## What is this library about?
`Elm-street` allows you to generate automatically derived from Haskell types
definitions of Elm data types, JSON encoders and decoders. This helps to avoid
writing and maintaining huge chunk of boilerplate code when developing full-stack
`elm-street` allows you to automatically generate definitions of Elm data types and compatible JSON encoders and decoders
from Haskell types. This helps to avoid writing and maintaining huge chunk of boilerplate code when developing full-stack
applications.
## Getting started
@ -56,13 +55,13 @@ In order to use `elm-street` features, you need to perform the following steps:
> **NOTE:** This requires extension `-XDataKinds`.
4. Use `generateElm` function to output definitions to specified directory under
specified module prefix.
```
```haskell
main :: IO ()
main = generateElm @Types $ defaultSettings "frontend/src" ["Core", "Generated"]
```
> **NOTE:** This requires extension `-XTypeApplications`.
The above command when called generates the following files:
When executed, the above program generates the following files:
+ `frontend/src/Core/Generated/Types.elm`: `Core.Generated.Types` module with the definitions of all types
+ `frontend/src/Core/Generated/Encoder.elm`: `Core.Generated.Encoder` module with the JSON encoders for the types
@ -102,7 +101,7 @@ limitations, specifically:
}
```
2. Data types with type variables are not supported (see [issue #45](https://github.com/Holmusk/elm-street/issues/45) for more details).
Though, if type variables are phantom, you still can implement `Elm` instance which
Though, if type variables are phantom, you can still implement `Elm` instance which
will generate valid Elm defintions. Here is how you can create `Elm` instance for
`newtype`s with phantom type variables:
```haskell

6
frontend/src/Core/Decoder.elm
View File

@ -16,6 +16,7 @@ decodePrims = D.succeed T.Prims
|> required "int" D.int
|> required "float" D.float
|> required "text" D.string
|> required "string" D.string
|> required "time" Iso.decoder
|> required "value" D.value
|> required "maybe" (nullable D.int)
@ -99,3 +100,8 @@ decodeOneType = D.succeed T.OneType
|> required "guests" (D.list decodeGuest)
|> required "userRequest" decodeUserRequest
|> required "nonEmpty" (elmStreetDecodeNonEmpty decodeMyUnit)
decodeCustomCodeGen : Decoder T.CustomCodeGen
decodeCustomCodeGen = D.succeed T.CustomCodeGen
|> required "customFunTestString" D.string
|> required "customFunTestInt" D.int

8
frontend/src/Core/Encoder.elm
View File

@ -16,6 +16,7 @@ encodePrims x = E.object
, ("int", E.int x.int)
, ("float", E.float x.float)
, ("text", E.string x.text)
, ("string", E.string x.string)
, ("time", Iso.encode x.time)
, ("value", Basics.identity x.value)
, ("maybe", (elmStreetEncodeMaybe E.int) x.maybe)
@ -94,3 +95,10 @@ encodeOneType x = E.object
, ("userRequest", encodeUserRequest x.userRequest)
, ("nonEmpty", (elmStreetEncodeNonEmpty encodeMyUnit) x.nonEmpty)
]
encodeCustomCodeGen : T.CustomCodeGen -> Value
encodeCustomCodeGen x = E.object
[ ("tag", E.string "CustomCodeGen")
, ("customFunTestString", E.string x.customFunTestString)
, ("customFunTestInt", E.int x.customFunTestInt)
]

6
frontend/src/Core/Types.elm
View File

@ -11,6 +11,7 @@ type alias Prims =
, int : Int
, float : Float
, text : String
, string : String
, time : Posix
, value : Value
, maybe : Maybe Int
@ -118,3 +119,8 @@ type alias OneType =
, userRequest : UserRequest
, nonEmpty : (MyUnit, List MyUnit)
}
type alias CustomCodeGen =
{ customFunTestString : String
, customFunTestInt : Int
}

1
frontend/tests/Tests.elm
View File

@ -47,6 +47,7 @@ defaultOneType =
, int = 42
, float = 36.6
, text = "heh"
, string = "bye"
, value = E.object
[ ("nullField", E.null)
, ("boolField", E.bool True)

6
frontend/tests/Tests/Golden.elm
View File

@ -36,7 +36,7 @@ goldenOneTypeJson =
"bool": true,
"unit": [],
"nonEmpty": [1],
"value" : {
"value": {
"boolField": true,
"numberField": 1,
"stringField": "hi",
@ -67,9 +67,9 @@ goldenOneTypeJson =
"limit": 123
},
"age": 18,
"newtype": 666,
"newtype": 666,
"newtypeList": [123],
"oneConstructor": "OneConstructor",
"oneConstructor": "OneConstructor",
"user": {
"status": "Approved",
"tag": "User",

95
src/Elm/Aeson.hs
View File

@ -1,5 +1,3 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
@ -10,7 +8,9 @@ comply to @elm-street@ rules regarding names.
module Elm.Aeson
( elmStreetParseJson
, elmStreetParseJsonWith
, elmStreetToJson
, elmStreetToJsonWith
, elmStreetJsonOptions
, ElmStreet (..)
@ -20,22 +20,20 @@ import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, Options (..), ToJSON (..),
defaultOptions, genericParseJSON, genericToJSON)
import Data.Aeson.Types (Parser)
import GHC.Generics (Generic, Rep)
import Type.Reflection (Typeable, typeRep)
import Type.Reflection (Typeable)
import Elm.Ast (TypeName (..))
import Elm.Generic (Elm (..), GenericElmDefinition (..), HasLessThanEightUnnamedFields,
HasNoNamedSum, HasNoTypeVars, stripTypeNamePrefix)
import Elm.Generic (Elm (..), CodeGenOptions (..), GenericElmDefinition (..), ElmStreetGenericConstraints, defaultCodeGenOptions)
import qualified Data.Text as T
import qualified GHC.Generics as Generic (from)
{- | Allows to create 'Data.Aeson.FromJSON' instance that strips the supported
by @elm-street@ data type name prefix from every field..
{- | Allows to create 'Data.Aeson.FromJSON' instance for data types supported by
@elm-street@. Strips data type name prefix from every field.
__Example:__
With the following @JSON@
The following @JSON@
@
{ \"name\": \"John\"
@ -43,16 +41,16 @@ With the following @JSON@
}
@
it is decoded it the following way for each of the specified types:
is decoded in the following way for each of the specified types:
+-------------------------------+--------------------------+
| Haskell data type | Parsed type |
+===============================+==========================+
| @ | @ |
| data User = User | User |
| \ { userName :: String | { userName = \"John\" |
| \ , userAge :: Int | , userAge = 42 |
| \ } | } |
| { userName :: String | { userName = \"John\" |
| , userAge :: Int | , userAge = 42 |
| } | } |
| @ | @ |
+-------------------------------+--------------------------+
| | |
@ -73,13 +71,13 @@ it is decoded it the following way for each of the specified types:
>>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show)
>>> instance FromJSON User where parseJSON = elmStreetParseJson
>>> decode @User "{ \"name\": \"John\", \"age\": 42 }"
>>> decode @User "{\"age\":42,\"name\":\"John\",\"tag\":\"User\"}"
Just (User {userName = "John", userAge = 42})
>>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show)
>>> instance FromJSON VeryLongType where parseJSON = elmStreetParseJson
>>> decode @VeryLongType "{ \"name\": \"John\", \"age\": 42 }"
>>> decode @VeryLongType "{\"age\":42,\"name\":\"John\",\"tag\":\"VeryLongType\"}"
Just (VeryLongType {vltName = "John", vltAge = 42})
-}
@ -88,57 +86,59 @@ elmStreetParseJson
(Typeable a, Generic a, GFromJSON Zero (Rep a))
=> Value
-> Parser a
elmStreetParseJson = genericParseJSON (elmStreetJsonOptions @a)
elmStreetParseJson = elmStreetParseJsonWith (defaultCodeGenOptions @a)
{- | Allows to create 'Data.Aeson.ToJSON' instance that strips the supported by
@elm-street@ data type name prefix from every field.
{- | Use custom 'CodeGenOptions' to customize the behavior of derived FromJSON instance.
-}
elmStreetParseJsonWith
:: forall a .
(Generic a, GFromJSON Zero (Rep a))
=> CodeGenOptions
-> Value
-> Parser a
elmStreetParseJsonWith options = genericParseJSON (elmStreetJsonOptions options)
{- | Allows to create 'Data.Aeson.ToJSON' instance for types supported by @elm-street@.
Strips type name prefix from every record field.
>>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show)
>>> instance ToJSON User where toJSON = elmStreetToJson
>>> encode $ User { userName = "John", userAge = 42 }
"{\"age\":42,\"name\":\"John\"}"
"{\"age\":42,\"name\":\"John\",\"tag\":\"User\"}"
>>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show)
>>> instance ToJSON VeryLongType where toJSON = elmStreetToJson
>>> encode $ VeryLongType {vltName = "John", vltAge = 42}
"{\"age\":42,\"name\":\"John\"}"
"{\"age\":42,\"name\":\"John\",\"tag\":\"VeryLongType\"}"
>>> data User = User { name :: String, age :: Int } deriving (Generic, Show)
>>> instance ToJSON User where toJSON = elmStreetToJson
>>> encode $ User { name = "John", age = 42 }
"{\"age\":42,\"name\":\"John\"}"
"{\"age\":42,\"name\":\"John\",\"tag\":\"User\"}"
-}
elmStreetToJson
:: forall a .
(Typeable a, Generic a, GToJSON Zero (Rep a))
=> a
-> Value
elmStreetToJson = genericToJSON (elmStreetJsonOptions @a)
{- | Options to strip type name from the field names.
+----------------+----------------+---------------------+
| Data type name | Field name | Stripped field name |
+================+================+=====================+
| @User@ | @userName@ | @name@ |
+----------------+----------------+---------------------+
| @AaaBbbCcc@ | @abcFieldName@ | @fieldName@ |
+----------------+----------------+---------------------+
| @Foo@ | @field@ | @field@ |
+----------------+----------------+---------------------+
| @Field@ | @field@ | @field@ |
+----------------+----------------+---------------------+
elmStreetToJson = elmStreetToJsonWith (defaultCodeGenOptions @a)
{- | Use custom 'CodeGenOptions' to customize the behavior of derived ToJSON instance.
-}
elmStreetJsonOptions :: forall a . Typeable a => Options
elmStreetJsonOptions = defaultOptions
{ fieldLabelModifier = T.unpack . stripTypeNamePrefix typeName . T.pack
elmStreetToJsonWith
:: forall a .
(Generic a, GToJSON Zero (Rep a))
=> CodeGenOptions
-> a
-> Value
elmStreetToJsonWith options = genericToJSON (elmStreetJsonOptions options)
-- | Build @elm-street@ compatible 'Data.Aeson.Options' from 'CodeGenOptions'.
elmStreetJsonOptions :: CodeGenOptions -> Options
elmStreetJsonOptions options = defaultOptions
{ fieldLabelModifier = T.unpack . cgoFieldLabelModifier options . T.pack
, tagSingleConstructors = True
}
where
typeName :: TypeName
typeName = TypeName $ T.pack $ show $ typeRep @a
{- | Newtype for reusing in @DerivingVia@.
@ -152,13 +152,8 @@ newtype ElmStreet a = ElmStreet
{ unElmStreet :: a
}
instance ( HasNoTypeVars a
, HasLessThanEightUnnamedFields a
, HasNoNamedSum a
, Generic a
, GenericElmDefinition (Rep a)
) => Elm (ElmStreet a) where
toElmDefinition _ = genericToElmDefinition
instance (ElmStreetGenericConstraints a, Typeable a) => Elm (ElmStreet a) where
toElmDefinition _ = genericToElmDefinition (defaultCodeGenOptions @a)
$ Generic.from (error "Proxy for generic elm was evaluated" :: a)
instance (Typeable a, Generic a, GToJSON Zero (Rep a)) => ToJSON (ElmStreet a) where

2
src/Elm/Generate.hs
View File

@ -1,5 +1,3 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

131
src/Elm/Generic.hs
View File

@ -1,5 +1,3 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
@ -28,6 +26,9 @@ module Elm.Generic
, GenericConstructor (..)
, toElmConstructor
-- * Customizing generated elm code and JSON instances
, CodeGenOptions (..)
, defaultCodeGenOptions
-- * Type families for compile-time checks
, HasNoTypeVars
@ -42,6 +43,7 @@ module Elm.Generic
, NamedSumError
, CheckNamedSum
, CheckConst
, ElmStreetGenericConstraints
-- * Internals
, stripTypeNamePrefix
@ -54,6 +56,7 @@ import Data.Kind (Constraint, Type)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Type.Reflection (Typeable, typeRep)
import Data.Time.Clock (UTCTime)
import Data.Type.Bool (If, type (||))
import Data.Void (Void)
@ -77,15 +80,10 @@ class Elm a where
toElmDefinition :: Proxy a -> ElmDefinition
default toElmDefinition
:: ( HasNoTypeVars a
, HasLessThanEightUnnamedFields a
, HasNoNamedSum a
, Generic a
, GenericElmDefinition (Rep a)
)
:: (ElmStreetGenericConstraints a, Typeable a)
=> Proxy a
-> ElmDefinition
toElmDefinition _ = genericToElmDefinition
toElmDefinition _ = genericToElmDefinition (defaultCodeGenOptions @a)
$ Generic.from (error "Proxy for generic elm was evaluated" :: a)
{- | Returns 'TypeRef' for the existing type. This function always returns the
@ -182,10 +180,10 @@ data type like @data type name@. Then it collects all constructors of the data
type and decides what to generate.
-}
class GenericElmDefinition (f :: k -> Type) where
genericToElmDefinition :: f a -> ElmDefinition
genericToElmDefinition :: CodeGenOptions -> f a -> ElmDefinition
instance (Datatype d, GenericElmConstructors f) => GenericElmDefinition (D1 d f) where
genericToElmDefinition datatype = case genericToElmConstructors (TypeName typeName) (unM1 datatype) of
genericToElmDefinition options datatype = case genericToElmConstructors options (unM1 datatype) of
c :| [] -> case toElmConstructor c of
Left fields -> DefRecord $ ElmRecord typeName fields elmIsNewtype
Right ctor -> DefType $ ElmType typeName [] elmIsNewtype (ctor :| [])
@ -232,34 +230,34 @@ toElmConstructor GenericConstructor{..} = case genericConstructorFields of
{- | Typeclass to collect all constructors of the Haskell data type generically. -}
class GenericElmConstructors (f :: k -> Type) where
genericToElmConstructors
:: TypeName -- ^ Name of the data type; to be stripped
:: CodeGenOptions
-> f a -- ^ Generic value
-> NonEmpty GenericConstructor -- ^ List of the data type constructors
-- | If it's a sum type then just combine constructors
instance (GenericElmConstructors f, GenericElmConstructors g) => GenericElmConstructors (f :+: g) where
genericToElmConstructors name _ =
genericToElmConstructors name (error "'f :+:' is evaluated" :: f p)
<> genericToElmConstructors name (error "':+: g' is evaluated" :: g p)
genericToElmConstructors options _ =
genericToElmConstructors options (error "'f :+:' is evaluated" :: f p)
<> genericToElmConstructors options (error "':+: g' is evaluated" :: g p)
-- | Create singleton list for case of a one constructor.
instance (Constructor c, GenericElmFields f) => GenericElmConstructors (C1 c f) where
genericToElmConstructors name constructor = pure $ GenericConstructor
genericToElmConstructors options constructor = pure $ GenericConstructor
(T.pack $ conName constructor)
(genericToElmFields name $ unM1 constructor)
(genericToElmFields options $ unM1 constructor)
-- | Collect all fields when inside constructor.
class GenericElmFields (f :: k -> Type) where
genericToElmFields
:: TypeName -- ^ Name of the data type; to be stripped
:: CodeGenOptions
-> f a -- ^ Generic value
-> [(TypeRef, Maybe Text)]
-- | If multiple fields then just combine all results.
instance (GenericElmFields f, GenericElmFields g) => GenericElmFields (f :*: g) where
genericToElmFields name _ =
genericToElmFields name (error "'f :*:' is evaluated" :: f p)
<> genericToElmFields name (error "':*: g' is evaluated" :: g p)
genericToElmFields options _ =
genericToElmFields options (error "'f :*:' is evaluated" :: f p)
<> genericToElmFields options (error "':*: g' is evaluated" :: g p)
-- | Constructor without fields.
instance GenericElmFields U1 where
@ -267,9 +265,9 @@ instance GenericElmFields U1 where
-- | Single constructor field.
instance (Selector s, Elm a) => GenericElmFields (S1 s (Rec0 a)) where
genericToElmFields typeName selector = case selName selector of
genericToElmFields options selector = case selName selector of
"" -> [(elmRef @a, Nothing)]
name -> [(elmRef @a, Just $ stripTypeNamePrefix typeName $ T.pack name)]
name -> [(elmRef @a, Just $ cgoFieldLabelModifier options $ T.pack name)]
{- | Strips name of the type name from field name prefix.
@ -303,6 +301,83 @@ stripTypeNamePrefix (TypeName typeName) fieldName =
leaveIfEmpty :: Text -> Text
leaveIfEmpty rest = if T.null rest then fieldName else headToLower rest
{- | CodeGenOptions allow for customizing some aspects of generated Elm code as well as
ToJSON and FromJSON instances derived generically.
They can be passed to 'elmStreetParseJsonWith', 'elmStreetToJsonWith' and 'genericToElmDefinition'
to influence the behavior of FromJSON \/ ToJSON and Elm instances respectively.
Note that for Generated Elm encoders \/ decoders to be compatible
with ToJSON \/ FromJSON instances for given type,
__the same CodeGenOptions must be used in Elm \/ ToJSON \/ FromJSON instance declarations__.
Example: Say you don't like the default behavior (stripping type name prefix from all record fields)
and you would like to keep all record field names unmodified instead.
You can achieve that by declaring custom options:
@
myCodeGenOptions :: CodeGenOptions
myCodeGenOptions = CodeGenOptions { cgoFieldLabelModifier = id }
@
And then pass these options when defining Elm \/ ToJSON \/ FromJSON instances.
It is recommended to use DerivingVia to reduce the amount of boilerplate needed.
First declare a newtype whose Elm \/ ToJSON \/ FromJSON instances use your custom CodeGenOptions:
@
newtype CustomElm a = CustomElm {unCustomElm :: a}
instance ElmStreetGenericConstraints a => Elm (CustomElm a) where
toElmDefinition _ = genericToElmDefinition myCodeGenOptions $
GHC.Generics.from (error "Proxy for generic elm was evaluated" :: a)
instance (Generic a, GToJSON Zero (Rep a)) => ToJSON (CustomElm a) where
toJSON = elmStreetToJsonWith myCodeGenOptions . unCustomElm
instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomElm a) where
parseJSON = fmap CustomElm . elmStreetParseJsonWith myCodeGenOptions
@
Then derive Elm \/ ToJSON \/ FromJSON instance via that newtype:
@
data MyType = MyType
{ myTypeFieldOne :: String
, myTypeFieldTwo :: Int
} deriving stock (Show, Generic)
deriving (Elm, ToJSON, FromJSON) via CustomElm MyType
@
We can check that type name prefix is no longer stripped from record field names:
>>> encode (MyType "Hello" 10)
"{\"myTypeFieldOne\":\"Hello\",\"myTypeFieldTwo\":10,\"tag\":\"MyType\"}"
-}
newtype CodeGenOptions = CodeGenOptions
{ cgoFieldLabelModifier :: Text -> Text -- ^ Function that modifies record field names (e.g. by dropping type name prefix)
}
{- | Options to strip type name from the field names.
+----------------+----------------+---------------------+
| Data type name | Field name | Stripped field name |
+================+================+=====================+
| @User@ | @userName@ | @name@ |
+----------------+----------------+---------------------+
| @AaaBbbCcc@ | @abcFieldName@ | @fieldName@ |
+----------------+----------------+---------------------+
| @Foo@ | @field@ | @field@ |
+----------------+----------------+---------------------+
| @Field@ | @field@ | @field@ |
+----------------+----------------+---------------------+
-}
defaultCodeGenOptions :: forall a. Typeable a => CodeGenOptions
defaultCodeGenOptions = CodeGenOptions (stripTypeNamePrefix typeName)
where
typeName :: TypeName
typeName = TypeName $ T.pack $ show $ typeRep @a
----------------------------------------------------------------------------
-- ~Magic~
----------------------------------------------------------------------------
@ -384,3 +459,13 @@ type family NamedSumError (t :: k) :: ErrorMessage where
NamedSumError t =
'Text "'elm-street' doesn't support Sum types with records."
':$$: 'Text "But '" ':<>: 'ShowType t ':<>: 'Text "' has records."
-- | Convenience grouping of constraints that type has to satisfy
-- in order to be eligible for automatic derivation of Elm instance via generics
type ElmStreetGenericConstraints a =
( HasNoTypeVars a
, HasLessThanEightUnnamedFields a
, HasNoNamedSum a
, Generic a
, GenericElmDefinition (Rep a)
)

33
test/Test/Golden.hs
View File

@ -1,20 +1,25 @@
module Test.Golden
( goldenSpec
) where
module Test.Golden (goldenSpec) where
import Test.Hspec (Spec, describe, it, runIO, shouldBe)
import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)
import Types (OneType, defaultOneType)
import Data.Aeson as A
import Data.ByteString.Lazy as LBS
import Types (CustomCodeGen, OneType, defaultCustomCodeGen, defaultOneType)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
goldenSpec :: Spec
goldenSpec = describe "golden tests" $ do
golden <- runIO $ LBS.readFile "test/golden/oneType.json"
it "Golden JSON -> Haskell == default" $
A.eitherDecode @OneType golden `shouldBe` Right defaultOneType
it "default -> JSON -> Haskell == default" $
(A.eitherDecode @OneType $ A.encode defaultOneType) `shouldBe` Right defaultOneType
describe "Default CodeGenOptions" $ do
it "Golden JSON -> Haskell == default" $
A.eitherDecode @OneType <$> LBS.readFile "test/golden/oneType.json"
`shouldReturn` Right defaultOneType
it "default -> JSON -> Haskell == default" $
A.eitherDecode @OneType (A.encode defaultOneType)
`shouldBe` Right defaultOneType
describe "Custom CodeGenOptions" $ do
it "should decode type with custom CodeGenOptions" $
A.eitherDecode @CustomCodeGen "{\"customFunTestInt\": 78,\"customFunTestString\": \"Hello\",\"tag\": \"CustomCodeGen\"}"
`shouldBe` Right defaultCustomCodeGen
it "should encode type with custom CodeGen" $
A.eitherDecode @CustomCodeGen (A.encode defaultCustomCodeGen)
`shouldBe` Right defaultCustomCodeGen

9
test/golden/oneType.json
View File

@ -31,14 +31,14 @@
"bool": true,
"unit": [],
"nonEmpty": [1],
"value" : {
"value": {
"boolField": true,
"numberField": 1,
"stringField": "hi",
"objectField": {},
"arrayField": [1,2,3],
"nullField": null
}
}
},
"myUnit": {
"tag": "MyUnit",
@ -62,9 +62,9 @@
"limit": 123
},
"age": 18,
"newtype": 666,
"newtype": 666,
"newtypeList": [123],
"oneConstructor": "OneConstructor",
"oneConstructor": "OneConstructor",
"user": {
"status": "Approved",
"tag": "User",
@ -101,3 +101,4 @@
}
]
}

84
types/Types.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{- | Haskell types used for testing `elm-street` generated Elm types.
-}
@ -10,6 +11,7 @@ module Types
( Types
, OneType (..)
, defaultOneType
, defaultCustomCodeGen
-- * All test types
, Prims (..)
@ -22,17 +24,22 @@ module Types
, User (..)
, Guest (..)
, UserRequest (..)
, CustomCodeGen (..)
) where
import Data.Aeson (FromJSON (..), ToJSON (..), Value(..), object, (.=))
import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), object, (.=), GFromJSON, GToJSON, Zero)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime (..))
import Data.Word (Word32)
import Elm (Elm (..), ElmStreet (..), elmNewtype, elmStreetParseJson, elmStreetToJson)
import GHC.Generics (Generic)
import Elm (Elm (..), ElmStreet (..), elmNewtype)
import Elm.Generic (CodeGenOptions (..), ElmStreetGenericConstraints, GenericElmDefinition(..))
import Elm.Aeson (elmStreetParseJsonWith, elmStreetToJsonWith)
import GHC.Generics (Generic, Rep)
import qualified GHC.Generics as Generic (from)
import qualified Data.Text as Text
data Prims = Prims
{ primsUnit :: !()
@ -79,20 +86,14 @@ newtype NewtypeList = NewtypeList [Int]
data OneConstructor = OneConstructor
deriving stock (Generic, Eq, Show)
deriving anyclass (Elm)
instance ToJSON OneConstructor where toJSON = elmStreetToJson
instance FromJSON OneConstructor where parseJSON = elmStreetParseJson
deriving (Elm, FromJSON, ToJSON) via ElmStreet OneConstructor
data RequestStatus
= Approved
| Rejected
| Reviewing
deriving (Generic, Eq, Show)
deriving anyclass (Elm)
instance ToJSON RequestStatus where toJSON = elmStreetToJson
instance FromJSON RequestStatus where parseJSON = elmStreetParseJson
deriving (Elm, FromJSON, ToJSON) via ElmStreet RequestStatus
data User = User
{ userId :: !(Id User)
@ -100,10 +101,7 @@ data User = User
, userAge :: !Age
, userStatus :: !RequestStatus
} deriving (Generic, Eq, Show)
deriving anyclass (Elm)
instance ToJSON User where toJSON = elmStreetToJson
instance FromJSON User where parseJSON = elmStreetParseJson
deriving (Elm, FromJSON, ToJSON) via ElmStreet User
data Guest
= Regular Text Int
@ -111,20 +109,14 @@ data Guest
| Special (Maybe [Int])
| Blocked
deriving (Generic, Eq, Show)
deriving anyclass (Elm)
instance ToJSON Guest where toJSON = elmStreetToJson
instance FromJSON Guest where parseJSON = elmStreetParseJson
deriving (Elm, FromJSON, ToJSON) via ElmStreet Guest
data UserRequest = UserRequest
{ userRequestIds :: ![Id User]
, userRequestLimit :: !Word32
, userRequestExample :: !(Maybe (Either User Guest))
} deriving (Generic, Eq, Show)
deriving anyclass (Elm)
instance ToJSON UserRequest where toJSON = elmStreetToJson
instance FromJSON UserRequest where parseJSON = elmStreetParseJson
deriving (Elm, FromJSON, ToJSON) via ElmStreet UserRequest
data MyUnit = MyUnit ()
deriving stock (Show, Eq, Ord, Generic)
@ -135,10 +127,7 @@ data MyResult
= Ok
| Err Text
deriving (Generic, Eq, Show)
deriving anyclass (Elm)
instance ToJSON MyResult where toJSON = elmStreetToJson
instance FromJSON MyResult where parseJSON = elmStreetParseJson
deriving (Elm, FromJSON, ToJSON) via ElmStreet MyResult
-- | All test types together in one type to play with.
data OneType = OneType
@ -156,10 +145,30 @@ data OneType = OneType
, oneTypeUserRequest :: !UserRequest
, oneTypeNonEmpty :: !(NonEmpty MyUnit)
} deriving (Generic, Eq, Show)
deriving anyclass (Elm)
deriving (Elm, FromJSON, ToJSON) via ElmStreet OneType
instance ToJSON OneType where toJSON = elmStreetToJson
instance FromJSON OneType where parseJSON = elmStreetParseJson
data CustomCodeGen = CustomCodeGen
{ customCodeGenString :: String
, customCodeGenInt :: Int
} deriving stock (Generic, Eq, Show)
deriving (Elm, FromJSON, ToJSON) via CustomElm CustomCodeGen
-- Settings which do some custom modifications of record filed names
customCodeGenOptions :: CodeGenOptions
customCodeGenOptions = CodeGenOptions (Text.replace "CodeGen" "FunTest")
-- Newtype whose Elm/ToJSON/FromJSON instance use custom CodeGenOptions
newtype CustomElm a = CustomElm {unCustomElm :: a}
instance ElmStreetGenericConstraints a => Elm (CustomElm a) where
toElmDefinition _ = genericToElmDefinition customCodeGenOptions
$ Generic.from (error "Proxy for generic elm was evaluated" :: a)
instance (Generic a, GToJSON Zero (Rep a)) => ToJSON (CustomElm a) where
toJSON = elmStreetToJsonWith customCodeGenOptions . unCustomElm
instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomElm a) where
parseJSON = fmap CustomElm . elmStreetParseJsonWith customCodeGenOptions
-- | Type level list of all test types.
type Types =
@ -176,6 +185,7 @@ type Types =
, Guest
, UserRequest
, OneType
, CustomCodeGen
]
@ -233,3 +243,9 @@ defaultOneType = OneType
, userRequestLimit = 123
, userRequestExample = Just (Right Blocked)
}
defaultCustomCodeGen :: CustomCodeGen
defaultCustomCodeGen = CustomCodeGen
{ customCodeGenString = "Hello"
, customCodeGenInt = 78
}