diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ `elm-street` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## Unreleased + +## 0.2.0.0 - Mar 29, 2022 + +* Remove GHC 8.4.4 and 8.6.5 from CI / tested-with +* Add GHC 8.10.7, 9.0.2 and 9.2.2 to CI / tested-with +* Support Json.Decode.Value as primitive +* Add primitive to represent NonEmpty lists as (a, List a) on elm side +* Add overlapping instance for Elm String, to ensure that Haskell `String`s are represented as `String` on Elm side (not as `List Char`) ## 0.1.0.4 - Jan 28, 2020 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ Crossing the road between Haskell and Elm. -## What this library about? +## 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 diff --git a/elm-street.cabal b/elm-street.cabal --- a/elm-street.cabal +++ b/elm-street.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: elm-street -version: 0.1.0.4 +version: 0.2.0.0 synopsis: Crossing the road between Haskell and Elm description: `Elm-street` allows you to generate automatically derived from Haskell types @@ -18,17 +18,17 @@ build-type: Simple extra-doc-files: README.md CHANGELOG.md -tested-with: GHC == 8.4.4 - GHC == 8.6.5 - GHC == 8.8.4 - GHC == 8.10.3 +tested-with: GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.2 source-repository head type: git location: https://github.com/Holmusk/elm-street.git common common-options - build-depends: base >= 4.11.1.0 && < 4.15 + build-depends: base >= 4.11.1.0 && < 4.17 ghc-options: -Wall -Wincomplete-uni-patterns @@ -69,12 +69,13 @@ Elm.Print.Decoder Elm.Print.Encoder Elm.Print.Types + other-modules: Internal.Prettyprinter.Compat build-depends: aeson >= 1.3 , directory ^>= 1.3 , filepath ^>= 1.4 , prettyprinter >= 1.2.1 && < 1.8 - , text ^>= 1.2 + , text >= 1.2 && <= 2.0 , time library types @@ -108,8 +109,8 @@ main-is: Main.hs other-modules: Api - build-depends: servant >= 0.14 && < 0.19 - , servant-server >= 0.14 && < 0.19 + build-depends: servant >= 0.14 + , servant-server >= 0.14 , types , wai ^>= 3.2 , warp < 3.4 @@ -128,8 +129,8 @@ build-depends: elm-street , types , aeson - , bytestring ^>= 0.10 - , hspec ^>= 2.7.1 + , bytestring >= 0.10 + , hspec >= 2.7.1 ghc-options: -threaded -rtsopts diff --git a/src/Elm/Ast.hs b/src/Elm/Ast.hs --- a/src/Elm/Ast.hs +++ b/src/Elm/Ast.hs @@ -5,7 +5,7 @@ module Elm.Ast ( ElmDefinition (..) - , ElmAlias (..) + , ElmRecord (..) , ElmType (..) , ElmPrim (..) @@ -25,19 +25,19 @@ -- | Elm data type definition. data ElmDefinition - = DefAlias !ElmAlias - | DefType !ElmType - | DefPrim !ElmPrim + = DefRecord !ElmRecord + | DefType !ElmType + | DefPrim !ElmPrim deriving (Show) --- | AST for @type alias@ in Elm. -data ElmAlias = ElmAlias - { elmAliasName :: !Text -- ^ Name of the alias - , elmAliasFields :: !(NonEmpty ElmRecordField) -- ^ List of fields - , elmAliasIsNewtype :: !Bool -- ^ 'True' if Haskell type is a @newtype@ +-- | AST for @record type alias@ in Elm. +data ElmRecord = ElmRecord + { elmRecordName :: !Text -- ^ Name of the record + , elmRecordFields :: !(NonEmpty ElmRecordField) -- ^ List of fields + , elmRecordIsNewtype :: !Bool -- ^ 'True' if Haskell type is a @newtype@ } deriving (Show) --- | Single file of @type alias@. +-- | Single field of @record type alias@. data ElmRecordField = ElmRecordField { elmRecordFieldType :: !TypeRef , elmRecordFieldName :: !Text @@ -80,11 +80,13 @@ | ElmFloat -- ^ @Float@ | ElmString -- ^ @String@ | ElmTime -- ^ @Posix@ in elm, @UTCTime@ in Haskell + | ElmValue -- ^ @Json.Encode.Value@ in elm, @Data.Aeson.Value@ in Haskell | ElmMaybe !TypeRef -- ^ @Maybe T@ | ElmResult !TypeRef !TypeRef -- ^ @Result A B@ in elm | ElmPair !TypeRef !TypeRef -- ^ @(A, B)@ in elm | ElmTriple !TypeRef !TypeRef !TypeRef -- ^ @(A, B, C)@ in elm | ElmList !TypeRef -- ^ @List A@ in elm + | ElmNonEmptyPair !TypeRef -- ^ @NonEmpty A@ represented by @(A, List A)@ in elm deriving (Show) -- | Reference to another existing type. @@ -96,6 +98,6 @@ -- | Extracts reference to the existing data type type from some other type elm defintion. definitionToRef :: ElmDefinition -> TypeRef definitionToRef = \case - DefAlias ElmAlias{..} -> RefCustom $ TypeName elmAliasName + DefRecord ElmRecord{..} -> RefCustom $ TypeName elmRecordName DefType ElmType{..} -> RefCustom $ TypeName elmTypeName DefPrim elmPrim -> RefPrim elmPrim diff --git a/src/Elm/Generate.hs b/src/Elm/Generate.hs --- a/src/Elm/Generate.hs +++ b/src/Elm/Generate.hs @@ -22,7 +22,7 @@ import System.FilePath ((<.>), ()) import Elm.Generic (Elm (..)) -import Elm.Print (decodeChar, decodeEither, decodeEnum, decodePair, decodeTriple, encodeEither, encodeMaybe, +import Elm.Print (decodeChar, decodeEither, decodeEnum, decodePair, decodeTriple, decodeNonEmpty, encodeEither, encodeMaybe, encodeNonEmpty, encodePair, encodeTriple, prettyShowDecoder, prettyShowDefinition, prettyShowEncoder) import qualified Data.Text as T @@ -123,6 +123,7 @@ [ "module " <> typesModule <> " exposing (..)" , "" , "import Time exposing (Posix)" + , "import Json.Decode exposing (Value)" ] encoderHeader :: Text @@ -161,10 +162,12 @@ , encodeEither , encodePair , encodeTriple + , encodeNonEmpty , decodeEnum , decodeChar , decodeEither , decodePair , decodeTriple + , decodeNonEmpty ] diff --git a/src/Elm/Generic.hs b/src/Elm/Generic.hs --- a/src/Elm/Generic.hs +++ b/src/Elm/Generic.hs @@ -8,7 +8,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {- | Generic conversion of Haskell data types to Elm types. @@ -48,6 +47,7 @@ , stripTypeNamePrefix ) where +import Data.Aeson (Value) import Data.Char (isLower, toLower) import Data.Int (Int16, Int32, Int8) import Data.Kind (Constraint, Type) @@ -58,12 +58,12 @@ import Data.Type.Bool (If, type (||)) import Data.Void (Void) import Data.Word (Word16, Word32, Word8) -import GHC.Generics ((:*:), (:+:), C1, Constructor (..), D1, Datatype (..), Generic (..), M1 (..), - Meta (..), Rec0, S1, Selector (..), U1) +import GHC.Generics (C1, Constructor (..), D1, Datatype (..), Generic (..), M1 (..), Meta (..), + Rec0, S1, Selector (..), U1, (:*:), (:+:)) import GHC.TypeLits (ErrorMessage (..), Nat, TypeError) import GHC.TypeNats (type (+), type (<=?)) -import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), +import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), definitionToRef) import qualified Data.Text as T @@ -118,6 +118,8 @@ instance Elm Text where toElmDefinition _ = DefPrim ElmString instance Elm LT.Text where toElmDefinition _ = DefPrim ElmString +instance Elm Value where toElmDefinition _ = DefPrim ElmValue + -- TODO: should it be 'Bytes' from @bytes@ package? -- https://package.elm-lang.org/packages/elm/bytes/latest/Bytes -- instance Elm B.ByteString where toElmDefinition _ = DefPrim ElmString @@ -140,8 +142,13 @@ instance Elm a => Elm [a] where toElmDefinition _ = DefPrim $ ElmList (elmRef @a) +-- Overlapping instance to ensure that Haskell @String@ is represented as Elm @String@ +-- and not as @List Char@ based based on @Elm a => Elm [a]@ instance +instance {-# OVERLAPPING #-} Elm String where + toElmDefinition _ = DefPrim ElmString + instance Elm a => Elm (NonEmpty a) where - toElmDefinition _ = DefPrim $ ElmList (elmRef @a) + toElmDefinition _ = DefPrim $ ElmNonEmptyPair (elmRef @a) ---------------------------------------------------------------------------- -- Smart constructors @@ -159,10 +166,10 @@ @ -} elmNewtype :: forall a . Elm a => Text -> Text -> ElmDefinition -elmNewtype typeName fieldName = DefAlias $ ElmAlias - { elmAliasName = typeName - , elmAliasFields = ElmRecordField (elmRef @a) fieldName :| [] - , elmAliasIsNewtype = True +elmNewtype typeName fieldName = DefRecord $ ElmRecord + { elmRecordName = typeName + , elmRecordFields = ElmRecordField (elmRef @a) fieldName :| [] + , elmRecordIsNewtype = True } ---------------------------------------------------------------------------- @@ -180,7 +187,7 @@ instance (Datatype d, GenericElmConstructors f) => GenericElmDefinition (D1 d f) where genericToElmDefinition datatype = case genericToElmConstructors (TypeName typeName) (unM1 datatype) of c :| [] -> case toElmConstructor c of - Left fields -> DefAlias $ ElmAlias typeName fields elmIsNewtype + Left fields -> DefRecord $ ElmRecord typeName fields elmIsNewtype Right ctor -> DefType $ ElmType typeName [] elmIsNewtype (ctor :| []) c :| cs -> case traverse (rightToMaybe . toElmConstructor) (c :| cs) of -- TODO: this should be error but dunno what to do here diff --git a/src/Elm/Print.hs b/src/Elm/Print.hs --- a/src/Elm/Print.hs +++ b/src/Elm/Print.hs @@ -15,16 +15,19 @@ import Elm.Print.Types {- -putStrLn $ T.unpack $ prettyShowDefinition $ DefAlias $ ElmAlias "User" $ (ElmRecordField (TypeName "String") "userHeh") :| [ElmRecordField (TypeName "Int") "userMeh"] - -ENUM: -putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] $ (ElmConstructor "Approved" []) :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" []] -putStrLn $ T.unpack $ prettyShowEncoder $ DefType $ ElmType "Status" [] $ (ElmConstructor "Approved" []) :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" []] - -putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] $ (ElmConstructor "Approved" [TypeName "String", TypeName "Int"]) :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [TypeName "a"]] +import qualified Data.Text as T +import Elm.Ast +import Data.List.NonEmpty -putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" ["a"] $ (ElmConstructor "Approved" [TypeName "String", TypeName "Int"]) :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [TypeName "a"]] +test :: IO () +test = do + putStrLn $ T.unpack $ prettyShowDefinition $ DefRecord $ ElmRecord "User" (ElmRecordField (RefPrim ElmString) "userHeh" :| [ElmRecordField (RefPrim ElmInt) "userMeh"]) False -putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] ((ElmConstructor "Approved" []) :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [], ElmConstructor "OneMore" [], ElmConstructor "AndAnother" []]) + --ENUM: + putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] False $ ElmConstructor "Approved" [] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" []] + putStrLn $ T.unpack $ prettyShowEncoder $ DefType $ ElmType "Status" [] False $ ElmConstructor "Approved" [] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" []] + putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] False $ ElmConstructor "Approved" [RefPrim ElmString, RefPrim ElmInt] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [RefCustom $ TypeName "a"]] + putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" ["a"] False $ ElmConstructor "Approved" [RefPrim ElmString, RefPrim ElmInt] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [RefCustom $ TypeName "a"]] + putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] False (ElmConstructor "Approved" [] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [], ElmConstructor "OneMore" [], ElmConstructor "AndAnother" []]) -} diff --git a/src/Elm/Print/Common.hs b/src/Elm/Print/Common.hs --- a/src/Elm/Print/Common.hs +++ b/src/Elm/Print/Common.hs @@ -12,7 +12,7 @@ ) where import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, concatWith, parens, pretty, surround, (<+>)) +import Internal.Prettyprinter.Compat (Doc, concatWith, parens, pretty, surround, (<+>)) import qualified Data.Text as T diff --git a/src/Elm/Print/Decoder.hs b/src/Elm/Print/Decoder.hs --- a/src/Elm/Print/Decoder.hs +++ b/src/Elm/Print/Decoder.hs @@ -11,14 +11,15 @@ , decodeEither , decodePair , decodeTriple + , decodeNonEmpty ) where import Data.List.NonEmpty (toList) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, colon, concatWith, dquotes, emptyDoc, equals, line, nest, +import Internal.Prettyprinter.Compat (Doc, colon, concatWith, dquotes, emptyDoc, equals, line, nest, parens, pretty, surround, vsep, (<+>)) -import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), +import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), isEnum) import Elm.Print.Common (arrow, mkQualified, qualifiedTypeWithVarsDoc, showDoc, wrapParens) @@ -69,33 +70,33 @@ -} prettyShowDecoder :: ElmDefinition -> Text prettyShowDecoder def = showDoc $ case def of - DefAlias elmAlias -> aliasDecoderDoc elmAlias - DefType elmType -> typeDecoderDoc elmType - DefPrim _ -> emptyDoc + DefRecord elmRecord -> recordDecoderDoc elmRecord + DefType elmType -> typeDecoderDoc elmType + DefPrim _ -> emptyDoc -aliasDecoderDoc :: ElmAlias -> Doc ann -aliasDecoderDoc ElmAlias{..} = - decoderDef elmAliasName [] +recordDecoderDoc :: ElmRecord -> Doc ann +recordDecoderDoc ElmRecord{..} = + decoderDef elmRecordName [] <> line - <> if elmAliasIsNewtype + <> if elmRecordIsNewtype then newtypeDecoder else recordDecoder where newtypeDecoder :: Doc ann - newtypeDecoder = name <+> "D.map" <+> qualifiedAliasName - <+> wrapParens (typeRefDecoder $ elmRecordFieldType $ NE.head elmAliasFields) + newtypeDecoder = name <+> "D.map" <+> qualifiedRecordName + <+> wrapParens (typeRefDecoder $ elmRecordFieldType $ NE.head elmRecordFields) recordDecoder :: Doc ann recordDecoder = nest 4 $ vsep - $ (name <+> "D.succeed" <+> qualifiedAliasName) - : map fieldDecode (toList elmAliasFields) + $ (name <+> "D.succeed" <+> qualifiedRecordName) + : map fieldDecode (toList elmRecordFields) name :: Doc ann - name = decoderName elmAliasName <+> equals + name = decoderName elmRecordName <+> equals - qualifiedAliasName :: Doc ann - qualifiedAliasName = mkQualified elmAliasName + qualifiedRecordName :: Doc ann + qualifiedRecordName = mkQualified elmRecordName fieldDecode :: ElmRecordField -> Doc ann fieldDecode ElmRecordField{..} = case elmRecordFieldType of @@ -190,19 +191,21 @@ ElmFloat -> "D.float" ElmString -> "D.string" ElmTime -> "Iso.decoder" + ElmValue -> "D.value" ElmMaybe t -> "nullable" <+> wrapParens (typeRefDecoder t) - ElmResult l r -> "elmStreetDecodeEither" + ElmResult l r -> "elmStreetDecodeEither" <+> wrapParens (typeRefDecoder l) <+> wrapParens (typeRefDecoder r) - ElmPair a b -> "elmStreetDecodePair" + ElmPair a b -> "elmStreetDecodePair" <+> wrapParens (typeRefDecoder a) <+> wrapParens (typeRefDecoder b) - ElmTriple a b c -> "elmStreetDecodeTriple" + ElmTriple a b c -> "elmStreetDecodeTriple" <+> wrapParens (typeRefDecoder a) <+> wrapParens (typeRefDecoder b) <+> wrapParens (typeRefDecoder c) - ElmList l -> "D.list" <+> wrapParens (typeRefDecoder l) + ElmList l -> "D.list" <+> wrapParens (typeRefDecoder l) + ElmNonEmptyPair a -> "elmStreetDecodeNonEmpty" <+> wrapParens (typeRefDecoder a) -- | The definition of the @decodeTYPENAME@ function. decoderDef @@ -253,6 +256,15 @@ decodePair = T.unlines [ "elmStreetDecodePair : Decoder a -> Decoder b -> Decoder (a, b)" , "elmStreetDecodePair decA decB = D.map2 Tuple.pair (D.index 0 decA) (D.index 1 decB)" + ] + +-- | @JSON@ decoder Elm help function for List.NonEmpty. +decodeNonEmpty :: Text +decodeNonEmpty = T.unlines + [ "elmStreetDecodeNonEmpty : Decoder a -> Decoder (a, List a)" + , "elmStreetDecodeNonEmpty decA = D.list decA |> D.andThen (\\xs -> case xs of" + , " h::t -> D.succeed (h, t)" + , " _ -> D.fail \"Expecting non-empty array\")" ] -- | @JSON@ decoder Elm help function for 3-tuples. diff --git a/src/Elm/Print/Encoder.hs b/src/Elm/Print/Encoder.hs --- a/src/Elm/Print/Encoder.hs +++ b/src/Elm/Print/Encoder.hs @@ -10,15 +10,16 @@ , encodeEither , encodePair , encodeTriple + , encodeNonEmpty ) where import Data.List.NonEmpty (NonEmpty, toList) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, brackets, colon, comma, concatWith, dquotes, emptyDoc, +import Internal.Prettyprinter.Compat (Doc, brackets, colon, comma, concatWith, dquotes, emptyDoc, equals, lbracket, line, nest, parens, pretty, rbracket, surround, vsep, (<+>)) -import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), +import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), isEnum) import Elm.Print.Common (arrow, mkQualified, qualifiedTypeWithVarsDoc, showDoc, wrapParens) @@ -40,14 +41,14 @@ -} prettyShowEncoder :: ElmDefinition -> Text prettyShowEncoder def = showDoc $ case def of - DefAlias elmAlias -> aliasEncoderDoc elmAlias - DefType elmType -> typeEncoderDoc elmType - DefPrim _ -> emptyDoc + DefRecord elmRecord -> recordEncoderDoc elmRecord + DefType elmType -> typeEncoderDoc elmType + DefPrim _ -> emptyDoc -- | Encoder for 'ElmType' (which is either enum or the Sum type). typeEncoderDoc :: ElmType -> Doc ann typeEncoderDoc t@ElmType{..} = - -- function defenition: @encodeTypeName : TypeName -> Value@. + -- function definition: @encodeTypeName : TypeName -> Value@. encoderDef elmTypeName elmTypeVars <> line <> if isEnum t @@ -56,7 +57,7 @@ else if elmTypeIsNewtype -- if this is type with one constructor and one field then it should just call encoder for wrapped type then newtypeEncoder - -- If it sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@ + -- If it's sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@ else sumEncoder where enumEncoder :: Doc ann @@ -81,7 +82,7 @@ name :: Doc ann name = encoderName elmTypeName - -- | Create case clouse for each of the sum Constructors. + -- | Create case clause for each of the sum Constructors. mkCase :: ElmConstructor -> Doc ann mkCase ElmConstructor{..} = mkQualified elmConstructorName <+> vars @@ -90,8 +91,7 @@ where -- | Creates variables: @x1@ to @xN@, where N is the number of the constructor fields. fields :: [Doc ann] - fields = take (length elmConstructorFields) $ - map (pretty . mkText "x") [1..] + fields = map (pretty . mkText "x") [1 .. length elmConstructorFields] contents :: Doc ann contents = "," <+> parens (dquotes "contents" <> comma <+> contentsEnc) @@ -115,29 +115,29 @@ vars = concatWith (surround " ") fields -aliasEncoderDoc :: ElmAlias -> Doc ann -aliasEncoderDoc ElmAlias{..} = - encoderDef elmAliasName [] +recordEncoderDoc :: ElmRecord -> Doc ann +recordEncoderDoc ElmRecord{..} = + encoderDef elmRecordName [] <> line - <> if elmAliasIsNewtype + <> if elmRecordIsNewtype then newtypeEncoder else recordEncoder where newtypeEncoder :: Doc ann - newtypeEncoder = leftPart <+> fieldEncoderDoc (NE.head elmAliasFields) + newtypeEncoder = leftPart <+> fieldEncoderDoc (NE.head elmRecordFields) recordEncoder :: Doc ann recordEncoder = nest 4 $ vsep $ (leftPart <+> "E.object") - : fieldsEncode elmAliasFields + : fieldsEncode elmRecordFields leftPart :: Doc ann - leftPart = encoderName elmAliasName <+> "x" <+> equals + leftPart = encoderName elmRecordName <+> "x" <+> equals fieldsEncode :: NonEmpty ElmRecordField -> [Doc ann] fieldsEncode fields = - lbracket <+> mkTag elmAliasName + lbracket <+> mkTag elmRecordName : map ((comma <+>) . recordFieldDoc) (NE.toList fields) ++ [rbracket] @@ -183,6 +183,7 @@ ElmFloat -> "E.float" ElmString -> "E.string" ElmTime -> "Iso.encode" + ElmValue -> "Basics.identity" ElmMaybe t -> "elmStreetEncodeMaybe" <+> wrapParens (typeRefEncoder t) ElmResult l r -> "elmStreetEncodeEither" @@ -196,6 +197,8 @@ <+> wrapParens (typeRefEncoder b) <+> wrapParens (typeRefEncoder c) ElmList l -> "E.list" <+> wrapParens (typeRefEncoder l) + ElmNonEmptyPair a -> "elmStreetEncodeNonEmpty" + <+> wrapParens (typeRefEncoder a) -- | @JSON@ encoder Elm help function for 'Maybe's. encodeMaybe :: Text @@ -218,6 +221,13 @@ encodePair = T.unlines [ "elmStreetEncodePair : (a -> Value) -> (b -> Value) -> (a, b) -> Value" , "elmStreetEncodePair encA encB (a, b) = E.list identity [encA a, encB b]" + ] + +-- | @JSON@ encoder Elm help function for 2-tuples. +encodeNonEmpty :: Text +encodeNonEmpty = T.unlines + [ "elmStreetEncodeNonEmpty : (a -> Value) -> (a, List a) -> Value" + , "elmStreetEncodeNonEmpty encA (a, xs) = E.list encA <| a :: xs" ] -- | @JSON@ encoder Elm help function for 3-tuples. diff --git a/src/Elm/Print/Types.hs b/src/Elm/Print/Types.hs --- a/src/Elm/Print/Types.hs +++ b/src/Elm/Print/Types.hs @@ -54,17 +54,17 @@ ( prettyShowDefinition -- * Internal functions - , elmAliasDoc + , elmRecordDoc , elmTypeDoc ) where import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, align, colon, comma, dquotes, emptyDoc, equals, lbrace, line, +import Internal.Prettyprinter.Compat (Doc, align, colon, comma, dquotes, emptyDoc, equals, lbrace, line, lparen, nest, parens, pipe, pretty, prettyList, rbrace, rparen, sep, space, vsep, (<+>)) -import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), +import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), getConstructorNames, isEnum) import Elm.Print.Common (arrow, showDoc, typeWithVarsDoc, wrapParens) @@ -74,7 +74,7 @@ {- | Pretty shows Elm types. -* See 'elmAliasDoc' for examples of generated @type alias@. +* See 'elmRecordDoc' for examples of generated @record type alias@. * See 'elmTypeDoc' for examples of generated @type@. -} prettyShowDefinition :: ElmDefinition -> Text @@ -82,14 +82,14 @@ elmDoc :: ElmDefinition -> Doc ann elmDoc = \case - DefAlias elmAlias -> elmAliasDoc elmAlias - DefType elmType -> elmTypeDoc elmType - DefPrim _ -> emptyDoc + DefRecord elmRecord -> elmRecordDoc elmRecord + DefType elmType -> elmTypeDoc elmType + DefPrim _ -> emptyDoc -- | Pretty printer for type reference. elmTypeRefDoc :: TypeRef -> Doc ann elmTypeRefDoc = \case - RefPrim elmPrim -> elmPrimDoc elmPrim + RefPrim elmPrim -> elmPrimDoc elmPrim RefCustom (TypeName typeName) -> pretty typeName {- | Pretty printer for primitive Elm types. This pretty printer is used only to @@ -97,27 +97,29 @@ -} elmPrimDoc :: ElmPrim -> Doc ann elmPrimDoc = \case - ElmUnit -> "()" - ElmNever -> "Never" - ElmBool -> "Bool" - ElmChar -> "Char" - ElmInt -> "Int" - ElmFloat -> "Float" - ElmString -> "String" - ElmTime -> "Posix" - ElmMaybe t -> "Maybe" <+> elmTypeParenDoc t - ElmResult l r -> "Result" <+> elmTypeParenDoc l <+> elmTypeParenDoc r - ElmPair a b -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> rparen - ElmTriple a b c -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> comma <+> elmTypeRefDoc c <> rparen - ElmList l -> "List" <+> elmTypeParenDoc l + ElmUnit -> "()" + ElmNever -> "Never" + ElmBool -> "Bool" + ElmChar -> "Char" + ElmInt -> "Int" + ElmFloat -> "Float" + ElmString -> "String" + ElmTime -> "Posix" + ElmValue -> "Value" + ElmMaybe t -> "Maybe" <+> elmTypeParenDoc t + ElmResult l r -> "Result" <+> elmTypeParenDoc l <+> elmTypeParenDoc r + ElmPair a b -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> rparen + ElmTriple a b c -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> comma <+> elmTypeRefDoc c <> rparen + ElmList l -> "List" <+> elmTypeParenDoc l + ElmNonEmptyPair a -> lparen <> elmTypeRefDoc a <> comma <+> "List" <+> elmTypeRefDoc a <> rparen {- | Pretty-printer for types. Adds parens for both sides when needed (when type -contains of multiple words). +consists of multiple words). -} elmTypeParenDoc :: TypeRef -> Doc ann elmTypeParenDoc = wrapParens . elmTypeRefDoc -{- | Pretty printer for Elm aliases: +{- | Pretty printer for Elm records: @ type alias User = @@ -126,10 +128,10 @@ } @ -} -elmAliasDoc :: ElmAlias -> Doc ann -elmAliasDoc ElmAlias{..} = nest 4 $ - vsep $ ("type alias" <+> pretty elmAliasName <+> equals) - : fieldsDoc elmAliasFields +elmRecordDoc :: ElmRecord -> Doc ann +elmRecordDoc ElmRecord{..} = nest 4 $ + vsep $ ("type alias" <+> pretty elmRecordName <+> equals) + : fieldsDoc elmRecordFields where fieldsDoc :: NonEmpty ElmRecordField -> [Doc ann] fieldsDoc (fstR :| rest) = @@ -207,7 +209,7 @@ constructorDoc :: ElmConstructor -> Doc ann constructorDoc ElmConstructor{..} = sep $ - pretty elmConstructorName : map (wrapParens . elmTypeRefDoc) elmConstructorFields + pretty elmConstructorName : map elmTypeParenDoc elmConstructorFields -- Generates 'unTYPENAME' function for newtype unFunc :: Doc ann diff --git a/src/Internal/Prettyprinter/Compat.hs b/src/Internal/Prettyprinter/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Prettyprinter/Compat.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +module Internal.Prettyprinter.Compat (module PP) where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter as PP +#else +import Data.Text.Prettyprint.Doc as PP +#endif diff --git a/test/Test/Golden.hs b/test/Test/Golden.hs --- a/test/Test/Golden.hs +++ b/test/Test/Golden.hs @@ -2,7 +2,7 @@ ( goldenSpec ) where -import Test.Hspec (Spec, describe, it, runIO) +import Test.Hspec (Spec, describe, it, runIO, shouldBe) import Types (OneType, defaultOneType) @@ -15,6 +15,6 @@ golden <- runIO $ LBS.readFile "test/golden/oneType.json" it "Golden JSON -> Haskell == default" $ - A.eitherDecode @OneType golden == Right defaultOneType + A.eitherDecode @OneType golden `shouldBe` Right defaultOneType it "default -> JSON -> Haskell == default" $ - (A.eitherDecode @OneType $ A.encode defaultOneType) == Right defaultOneType + (A.eitherDecode @OneType $ A.encode defaultOneType) `shouldBe` Right defaultOneType diff --git a/types/Types.hs b/types/Types.hs --- a/types/Types.hs +++ b/types/Types.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -#if ( __GLASGOW_HASKELL__ >= 806 ) {-# LANGUAGE DerivingVia #-} -#endif {-# LANGUAGE DerivingStrategies #-} {- | Haskell types used for testing `elm-street` generated Elm types. @@ -27,7 +24,8 @@ , UserRequest (..) ) where -import Data.Aeson (FromJSON (..), ToJSON (..)) +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 (..)) @@ -37,28 +35,24 @@ data Prims = Prims - { primsUnit :: !() - , primsBool :: !Bool - , primsChar :: !Char - , primsInt :: !Int - , primsFloat :: !Double - , primsText :: !Text - , primsTime :: !UTCTime - , primsMaybe :: !(Maybe Word) - , primsResult :: !(Either Int Text) - , primsPair :: !(Char, Bool) - , primsTriple :: !(Char, Bool, [Int]) - , primsList :: ![Int] + { primsUnit :: !() + , primsBool :: !Bool + , primsChar :: !Char + , primsInt :: !Int + , primsFloat :: !Double + , primsText :: !Text + , primsString :: !String + , primsTime :: !UTCTime + , primsValue :: !Value + , primsMaybe :: !(Maybe Word) + , primsResult :: !(Either Int Text) + , primsPair :: !(Char, Bool) + , primsTriple :: !(Char, Bool, [Int]) + , primsList :: ![Int] + , primsNonEmpty :: !(NonEmpty Int) } deriving (Generic, Eq, Show) -#if ( __GLASGOW_HASKELL__ >= 806 ) deriving (Elm, ToJSON, FromJSON) via ElmStreet Prims -#else - deriving anyclass Elm -instance ToJSON Prims where toJSON = elmStreetToJson -instance FromJSON Prims where parseJSON = elmStreetParseJson -#endif - newtype Id a = Id { unId :: Text } deriving (Show, Eq) @@ -134,14 +128,7 @@ data MyUnit = MyUnit () deriving stock (Show, Eq, Ord, Generic) -#if ( __GLASGOW_HASKELL__ >= 806 ) - deriving (Elm, ToJSON, FromJSON) via ElmStreet MyUnit -#else - deriving anyclass Elm - -instance ToJSON MyUnit where toJSON = elmStreetToJson -instance FromJSON MyUnit where parseJSON = elmStreetParseJson -#endif + deriving (Elm, ToJSON, FromJSON) via ElmStreet MyUnit -- | For name clashes testing. data MyResult @@ -167,6 +154,7 @@ , oneTypeUser :: !User , oneTypeGuests :: ![Guest] , oneTypeUserRequest :: !UserRequest + , oneTypeNonEmpty :: !(NonEmpty MyUnit) } deriving (Generic, Eq, Show) deriving anyclass (Elm) @@ -205,22 +193,33 @@ , oneTypeUser = User (Id "1") "not-me" (Age 100) Approved , oneTypeGuests = [guestRegular, guestVisitor, guestBlocked] , oneTypeUserRequest = defaultUserRequest + , oneTypeNonEmpty = MyUnit () :| [ MyUnit () ] } where defaultPrims :: Prims defaultPrims = Prims - { primsUnit = () - , primsBool = True - , primsChar = 'a' - , primsInt = 42 - , primsFloat = 36.6 - , primsText = "heh" - , primsTime = UTCTime (fromGregorian 2019 2 22) 0 - , primsMaybe = Just 12 - , primsResult = Left 666 - , primsPair = ('o', False) - , primsTriple = ('o', False, [0]) - , primsList = [1..5] + { primsUnit = () + , primsBool = True + , primsChar = 'a' + , primsInt = 42 + , primsFloat = 36.6 + , primsText = "heh" + , primsString = "bye" + , primsValue = object + [ "nullField" .= Null + , "boolField" .= True + , "numberField" .= (1::Int) + , "stringField" .= ("hi"::String) + , "arrayField" .= [1::Int,2,3] + , "objectField" .= object [] + ] + , primsTime = UTCTime (fromGregorian 2019 2 22) 0 + , primsMaybe = Just 12 + , primsResult = Left 666 + , primsPair = ('o', False) + , primsTriple = ('o', False, [0]) + , primsList = [1..5] + , primsNonEmpty = 1 :| [] } guestRegular, guestVisitor, guestBlocked :: Guest