elm-street 0.1.0.4 → 0.2.0.0
raw patch · 14 files changed
+212/−156 lines, 14 filesdep ~basedep ~bytestringdep ~hspecPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, bytestring, hspec, servant, servant-server, text
API changes (from Hackage documentation)
- Elm.Ast: DefAlias :: !ElmAlias -> ElmDefinition
- Elm.Ast: ElmAlias :: !Text -> !NonEmpty ElmRecordField -> !Bool -> ElmAlias
- Elm.Ast: [elmAliasFields] :: ElmAlias -> !NonEmpty ElmRecordField
- Elm.Ast: [elmAliasIsNewtype] :: ElmAlias -> !Bool
- Elm.Ast: [elmAliasName] :: ElmAlias -> !Text
- Elm.Ast: data ElmAlias
- Elm.Ast: instance GHC.Show.Show Elm.Ast.ElmAlias
- Elm.Print.Types: elmAliasDoc :: ElmAlias -> Doc ann
+ Elm.Ast: DefRecord :: !ElmRecord -> ElmDefinition
+ Elm.Ast: ElmNonEmptyPair :: !TypeRef -> ElmPrim
+ Elm.Ast: ElmRecord :: !Text -> !NonEmpty ElmRecordField -> !Bool -> ElmRecord
+ Elm.Ast: ElmValue :: ElmPrim
+ Elm.Ast: [elmRecordFields] :: ElmRecord -> !NonEmpty ElmRecordField
+ Elm.Ast: [elmRecordIsNewtype] :: ElmRecord -> !Bool
+ Elm.Ast: [elmRecordName] :: ElmRecord -> !Text
+ Elm.Ast: data ElmRecord
+ Elm.Ast: instance GHC.Show.Show Elm.Ast.ElmRecord
+ Elm.Generic: instance Elm.Generic.Elm Data.Aeson.Types.Internal.Value
+ Elm.Generic: instance Elm.Generic.Elm GHC.Base.String
+ Elm.Print.Decoder: decodeNonEmpty :: Text
+ Elm.Print.Encoder: encodeNonEmpty :: Text
+ Elm.Print.Types: elmRecordDoc :: ElmRecord -> Doc ann
Files
- CHANGELOG.md +9/−0
- README.md +1/−1
- elm-street.cabal +12/−11
- src/Elm/Ast.hs +13/−11
- src/Elm/Generate.hs +4/−1
- src/Elm/Generic.hs +17/−10
- src/Elm/Print.hs +12/−9
- src/Elm/Print/Common.hs +1/−1
- src/Elm/Print/Decoder.hs +32/−20
- src/Elm/Print/Encoder.hs +28/−18
- src/Elm/Print/Types.hs +30/−28
- src/Internal/Prettyprinter/Compat.hs +8/−0
- test/Test/Golden.hs +3/−3
- types/Types.hs +42/−43
CHANGELOG.md view
@@ -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
README.md view
@@ -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
elm-street.cabal view
@@ -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
src/Elm/Ast.hs view
@@ -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
src/Elm/Generate.hs view
@@ -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 ]
src/Elm/Generic.hs view
@@ -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
src/Elm/Print.hs view
@@ -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" []]) -}
src/Elm/Print/Common.hs view
@@ -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
src/Elm/Print/Decoder.hs view
@@ -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.
src/Elm/Print/Encoder.hs view
@@ -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.
src/Elm/Print/Types.hs view
@@ -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
+ src/Internal/Prettyprinter/Compat.hs view
@@ -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
test/Test/Golden.hs view
@@ -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
types/Types.hs view
@@ -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