diff --git a/frontend/src/Core/Decoder.elm b/frontend/src/Core/Decoder.elm index 828db7d..94f183e 100644 --- a/frontend/src/Core/Decoder.elm +++ b/frontend/src/Core/Decoder.elm @@ -99,3 +99,7 @@ decodeOneType = D.succeed T.OneType |> required "guests" (D.list decodeGuest) |> required "userRequest" decodeUserRequest |> required "nonEmpty" (elmStreetDecodeNonEmpty decodeMyUnit) + |> required "recordUnit" decodeRecordUnit + +decodeRecordUnit : Decoder T.RecordUnit +decodeRecordUnit = D.succeed {} diff --git a/frontend/src/Core/Encoder.elm b/frontend/src/Core/Encoder.elm index 78a161f..11bfe8d 100644 --- a/frontend/src/Core/Encoder.elm +++ b/frontend/src/Core/Encoder.elm @@ -93,4 +93,8 @@ encodeOneType x = E.object , ("guests", (E.list encodeGuest) x.guests) , ("userRequest", encodeUserRequest x.userRequest) , ("nonEmpty", (elmStreetEncodeNonEmpty encodeMyUnit) x.nonEmpty) + , ("recordUnit", encodeRecordUnit x.recordUnit) ] + +encodeRecordUnit : T.RecordUnit -> Value +encodeRecordUnit x = list (\_ -> null) [] diff --git a/frontend/src/Core/Types.elm b/frontend/src/Core/Types.elm index 322805d..225db8f 100644 --- a/frontend/src/Core/Types.elm +++ b/frontend/src/Core/Types.elm @@ -117,4 +117,8 @@ type alias OneType = , guests : List Guest , userRequest : UserRequest , nonEmpty : (MyUnit, List MyUnit) + , recordUnit : RecordUnit } + +type alias RecordUnit = + { } diff --git a/frontend/tests/Tests.elm b/frontend/tests/Tests.elm index bd1dcfa..17e1f59 100644 --- a/frontend/tests/Tests.elm +++ b/frontend/tests/Tests.elm @@ -79,4 +79,5 @@ defaultOneType = , example = Just (R.Ok Blocked) } , nonEmpty = (MyUnit (), [MyUnit ()]) + , recordUnit = {} } diff --git a/frontend/tests/Tests/Golden.elm b/frontend/tests/Tests/Golden.elm index 553919a..6506fb9 100644 --- a/frontend/tests/Tests/Golden.elm +++ b/frontend/tests/Tests/Golden.elm @@ -103,6 +103,7 @@ goldenOneTypeJson = "tag": "MyUnit", "contents": [] } - ] + ], + "recordUnit": [] } """ diff --git a/src/Elm/Ast.hs b/src/Elm/Ast.hs index 451c43d..d6f2ea8 100644 --- a/src/Elm/Ast.hs +++ b/src/Elm/Ast.hs @@ -33,7 +33,7 @@ data ElmDefinition -- | AST for @record type alias@ in Elm. data ElmRecord = ElmRecord { elmRecordName :: !Text -- ^ Name of the record - , elmRecordFields :: !(NonEmpty ElmRecordField) -- ^ List of fields + , elmRecordFields :: ![ElmRecordField] -- ^ List of fields , elmRecordIsNewtype :: !Bool -- ^ 'True' if Haskell type is a @newtype@ } deriving (Show) diff --git a/src/Elm/Generic.hs b/src/Elm/Generic.hs index 72e6ffe..6f444fc 100644 --- a/src/Elm/Generic.hs +++ b/src/Elm/Generic.hs @@ -163,7 +163,7 @@ __instance__ Elm (Id a) __where__ elmNewtype :: forall a . Elm a => Text -> Text -> ElmDefinition elmNewtype typeName fieldName = DefRecord $ ElmRecord { elmRecordName = typeName - , elmRecordFields = ElmRecordField (elmRef @a) fieldName :| [] + , elmRecordFields = ElmRecordField (elmRef @a) fieldName : [] , elmRecordIsNewtype = True } @@ -213,10 +213,14 @@ data GenericConstructor = GenericConstructor 2. All fields have names: record constructor. 3. Not all fields have names: plain constructor. -} -toElmConstructor :: GenericConstructor -> Either (NonEmpty ElmRecordField) ElmConstructor +toElmConstructor :: GenericConstructor -> Either [ElmRecordField] ElmConstructor toElmConstructor GenericConstructor{..} = case genericConstructorFields of + -- Even though elm supports records with no field {} we don't ever derive these + -- Haskell records are in fact just type field accessors so there is ambiguity for zero fields constructors + -- Usually it makes more sense to derive Single constructor type for the Elm side so that's what we do + -- However it's possible to manually define instance of Elm class that would produce empty records (the other unit) type on Elm side [] -> Right $ ElmConstructor genericConstructorName [] - f:fs -> case traverse toRecordField (f :| fs) of + f:fs -> case traverse toRecordField (f : fs) of Nothing -> Right $ ElmConstructor genericConstructorName $ map fst genericConstructorFields Just fields -> Left fields where diff --git a/src/Elm/Print/Decoder.hs b/src/Elm/Print/Decoder.hs index e7cb857..70d7799 100644 --- a/src/Elm/Print/Decoder.hs +++ b/src/Elm/Print/Decoder.hs @@ -24,6 +24,7 @@ import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord import Elm.Print.Common (arrow, mkQualified, qualifiedTypeWithVarsDoc, showDoc, wrapParens) import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe import qualified Data.Text as T @@ -78,19 +79,31 @@ recordDecoderDoc :: ElmRecord -> Doc ann recordDecoderDoc ElmRecord{..} = decoderDef elmRecordName [] <> line - <> if elmRecordIsNewtype + <> if isEmptyRecord + then emptyRecordDecoder + else if elmRecordIsNewtype then newtypeDecoder else recordDecoder where + isEmptyRecord :: Bool + isEmptyRecord = null elmRecordFields + + emptyRecordDecoder :: Doc ann + emptyRecordDecoder = name <+> "D.succeed {}" + newtypeDecoder :: Doc ann - newtypeDecoder = name <+> "D.map" <+> qualifiedRecordName - <+> wrapParens (typeRefDecoder $ elmRecordFieldType $ NE.head elmRecordFields) + newtypeDecoder = + case typeRefDecoder <$> elmRecordFieldType <$> Maybe.listToMaybe elmRecordFields of + Just field -> + name <+> "D.map" <+> qualifiedRecordName + <+> wrapParens field + Nothing -> emptyRecordDecoder recordDecoder :: Doc ann recordDecoder = nest 4 $ vsep $ (name <+> "D.succeed" <+> qualifiedRecordName) - : map fieldDecode (toList elmRecordFields) + : map fieldDecode elmRecordFields name :: Doc ann name = decoderName elmRecordName <+> equals diff --git a/src/Elm/Print/Encoder.hs b/src/Elm/Print/Encoder.hs index de38e4d..f15d74b 100644 --- a/src/Elm/Print/Encoder.hs +++ b/src/Elm/Print/Encoder.hs @@ -13,7 +13,6 @@ module Elm.Print.Encoder , encodeNonEmpty ) where -import Data.List.NonEmpty (NonEmpty, toList) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, brackets, colon, comma, concatWith, dquotes, emptyDoc, equals, lbracket, line, nest, parens, pretty, rbracket, surround, @@ -24,6 +23,7 @@ import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord import Elm.Print.Common (arrow, mkQualified, qualifiedTypeWithVarsDoc, showDoc, wrapParens) import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe import qualified Data.Text as T @@ -76,7 +76,7 @@ typeEncoderDoc t@ElmType{..} = sumEncoder = nest 4 $ vsep $ (name <+> "x" <+> equals <+> "E.object <| case x of") - : map mkCase (toList elmTypeConstructors) + : map mkCase (NE.toList elmTypeConstructors) -- | Encoder function name name :: Doc ann @@ -119,12 +119,24 @@ recordEncoderDoc :: ElmRecord -> Doc ann recordEncoderDoc ElmRecord{..} = encoderDef elmRecordName [] <> line - <> if elmRecordIsNewtype - then newtypeEncoder - else recordEncoder + <> + if isEmptyRecord + then emptyRecordEncoder + else if elmRecordIsNewtype + then newtypeEncoder + else recordEncoder where + isEmptyRecord :: Bool + isEmptyRecord = null elmRecordFields + newtypeEncoder :: Doc ann - newtypeEncoder = leftPart <+> fieldEncoderDoc (NE.head elmRecordFields) + newtypeEncoder = + case fieldEncoderDoc <$> (Maybe.listToMaybe elmRecordFields) of + Just rightPart -> leftPart <+> rightPart + Nothing -> emptyRecordEncoder + + emptyRecordEncoder :: Doc ann + emptyRecordEncoder = leftPart <+> "list (\\_ -> null) []" recordEncoder :: Doc ann recordEncoder = nest 4 @@ -135,10 +147,10 @@ recordEncoderDoc ElmRecord{..} = leftPart :: Doc ann leftPart = encoderName elmRecordName <+> "x" <+> equals - fieldsEncode :: NonEmpty ElmRecordField -> [Doc ann] + fieldsEncode :: [ElmRecordField] -> [Doc ann] fieldsEncode fields = lbracket <+> mkTag elmRecordName - : map ((comma <+>) . recordFieldDoc) (NE.toList fields) + : map ((comma <+>) . recordFieldDoc) fields ++ [rbracket] recordFieldDoc :: ElmRecordField -> Doc ann diff --git a/src/Elm/Print/Types.hs b/src/Elm/Print/Types.hs index 6c1d854..6c65b1e 100644 --- a/src/Elm/Print/Types.hs +++ b/src/Elm/Print/Types.hs @@ -133,11 +133,13 @@ elmRecordDoc ElmRecord{..} = nest 4 $ vsep $ ("type alias" <+> pretty elmRecordName <+> equals) : fieldsDoc elmRecordFields where - fieldsDoc :: NonEmpty ElmRecordField -> [Doc ann] - fieldsDoc (fstR :| rest) = - lbrace <+> recordFieldDoc fstR - : map ((comma <+>) . recordFieldDoc) rest - ++ [rbrace] + fieldsDoc :: [ElmRecordField] -> [Doc ann] + fieldsDoc = \case + [] -> [lbrace <+> rbrace] + fstR : rest -> + lbrace <+> recordFieldDoc fstR + : map ((comma <+>) . recordFieldDoc) rest + ++ [rbrace] recordFieldDoc :: ElmRecordField -> Doc ann recordFieldDoc ElmRecordField{..} = diff --git a/test/golden/oneType.json b/test/golden/oneType.json index c031c7f..419f816 100644 --- a/test/golden/oneType.json +++ b/test/golden/oneType.json @@ -37,7 +37,7 @@ "objectField": {}, "arrayField": [1,2,3], "nullField": null - } + } }, "myUnit": { "tag": "MyUnit", @@ -98,5 +98,6 @@ "tag": "MyUnit", "contents": [] } - ] + ], + "recordUnit": [] } diff --git a/types/Types.hs b/types/Types.hs index 2572ac0..5d25fa3 100644 --- a/types/Types.hs +++ b/types/Types.hs @@ -27,13 +27,14 @@ module Types , UserRequest (..) ) where -import Data.Aeson (FromJSON (..), ToJSON (..), Value(..), object, (.=)) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, (.=)) +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 Elm (Elm (..), ElmDefinition (..), ElmRecord (..), ElmStreet (..), elmNewtype, + elmStreetParseJson, elmStreetToJson) import GHC.Generics (Generic) @@ -45,7 +46,7 @@ data Prims = Prims , primsFloat :: !Double , primsText :: !Text , primsTime :: !UTCTime - , primsValue :: !Value + , primsValue :: !Value , primsMaybe :: !(Maybe Word) , primsResult :: !(Either Int Text) , primsPair :: !(Char, Bool) @@ -150,12 +151,24 @@ instance FromJSON MyUnit where parseJSON = elmStreetParseJson data MyResult = Ok | Err Text - deriving (Generic, Eq, Show) + deriving stock (Generic, Eq, Show) deriving anyclass (Elm) instance ToJSON MyResult where toJSON = elmStreetToJson instance FromJSON MyResult where parseJSON = elmStreetParseJson +data RecordUnit = RecordUnit + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +instance Elm RecordUnit where + toElmDefinition _ = DefRecord $ ElmRecord + { elmRecordName = "RecordUnit" + , elmRecordFields = [] + , elmRecordIsNewtype = False + } + + -- | All test types together in one type to play with. data OneType = OneType { oneTypePrims :: !Prims @@ -171,6 +184,7 @@ data OneType = OneType , oneTypeGuests :: ![Guest] , oneTypeUserRequest :: !UserRequest , oneTypeNonEmpty :: !(NonEmpty MyUnit) + , oneTypeRecordUnit :: !RecordUnit } deriving (Generic, Eq, Show) deriving anyclass (Elm) @@ -192,6 +206,7 @@ type Types = , Guest , UserRequest , OneType + , RecordUnit ] @@ -210,6 +225,7 @@ defaultOneType = OneType , oneTypeGuests = [guestRegular, guestVisitor, guestBlocked] , oneTypeUserRequest = defaultUserRequest , oneTypeNonEmpty = MyUnit () :| [ MyUnit () ] + , oneTypeRecordUnit = RecordUnit } where defaultPrims :: Prims