diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,50 @@ `elm-street` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.1.0.0 — Sep 6, 2019 + +* [#80](https://github.com/holmusk/elm-street/issues/80): + **Important:** *All* encoders for constructors with fields now have `tag` due + to aeson decoder on Haskell side. + + **Migration guide 1:** Rename fields that will have `tag` name on the Elm + side. + + **Migration guide 2:** If you have manual `ToJSON` instances that communicate + with Elm via generated decoders, you need to add `tag` field with the + constructor name: + + ```haskell + data User = User { ... } + + instance ToJSON User where + toJSON = [ "tag" .= ("User" :: Text), ... ] + ``` + +* [#71](https://github.com/holmusk/elm-street/issues/71): + **Breaking change:** Remove **overlapping** instance for `String`. + + **Migration guide:** Use `Text` instead of `String`. + +* [#70](https://github.com/holmusk/elm-street/issues/70): + Use qualified imports of generated types and function in Elm generated files. +* [#74](https://github.com/holmusk/elm-street/issues/74): + Fix unit type `typeRef` encoder and decoder printers. +* [#72](https://github.com/holmusk/elm-street/issues/72): + Use consistent encoders and decoders for unary constructors. +* [#79](https://github.com/holmusk/elm-street/issues/79): + Implement cross-language golden tests. +* [#76](https://github.com/holmusk/elm-street/issues/76): + Support GHC-8.6.5. Use common stanzas. +* [#86](https://github.com/holmusk/elm-street/issues/86): + Refactor `Elm.Print` module and split into multiple smaller modules. +* [#73](https://github.com/holmusk/elm-street/issues/73): + Clarify the restriction with reserved words in documentation. +* [#90](https://github.com/Holmusk/elm-street/issues/90) + Support converting 3-tuples. +* [#6](https://github.com/holmusk/elm-street/issues/6): + Test generated Elm code on CI. + ## 0.0.1 — Mar 29, 2019 * [#64](https://github.com/holmusk/elm-street/issues/64): diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -145,6 +145,22 @@ instances from the `aeson` package. 7. Only `UTCTime` Haskell data type is supported and it's translated to `Posix` type in Elm. +8. Some words in Elm are considered reserved and naming a record field with one of these words (prefixed with the type name, see 1) will result in the generated Elm files to not compile. So, the following words should not be used as field names: + * `if` + * `then` + * `else` + * `case` + * `of` + * `let` + * `in` + * `type` + * `module` + * `where` + * `import` + * `exposing` + * `as` + * `port` + * `tag` (reserved for constructor name due to `aeson` options) ## Play with frontend example diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/backend/Main.hs b/backend/Main.hs --- a/backend/Main.hs +++ b/backend/Main.hs @@ -1,4 +1,4 @@ -module Main where +module Main (main) where import Network.Wai.Handler.Warp (run) 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.0 +cabal-version: 2.4 name: elm-street -version: 0.0.1 +version: 0.1.0.0 synopsis: Crossing the road between Haskell and Elm description: `Elm-street` allows you to generate automatically derived from Haskell types @@ -11,35 +11,22 @@ bug-reports: https://github.com/Holmusk/elm-street/issues license: MPL-2.0 license-file: LICENSE -author: Holmusk -maintainer: tech@holmusk.com +author: Veronika Romashkina, Dmitrii Kovanikov +maintainer: Holmusk copyright: 2019 Holmusk category: Language, Compiler, Elm build-type: Simple extra-doc-files: README.md - , CHANGELOG.md -tested-with: GHC == 8.4.4, GHC == 8.6.3 + CHANGELOG.md +tested-with: GHC == 8.4.4 + GHC == 8.6.5 source-repository head type: git location: https://github.com/Holmusk/elm-street.git -library - hs-source-dirs: src - exposed-modules: Elm - Elm.Aeson - Elm.Ast - Elm.Generate - Elm.Generic - Elm.Print - +common common-options build-depends: base >= 4.11.1.0 && < 4.13 - , aeson >= 1.3 - , directory ^>= 1.3 - , filepath ^>= 1.4 - , prettyprinter ^>= 1.2.1 - , text ^>= 1.2 - , time ghc-options: -Wall -Wincomplete-uni-patterns @@ -64,136 +51,84 @@ StandaloneDeriving TupleSections TypeApplications + TypeOperators ViewPatterns +library + import: common-options + hs-source-dirs: src + exposed-modules: Elm + Elm.Aeson + Elm.Ast + Elm.Generate + Elm.Generic + Elm.Print + Elm.Print.Common + Elm.Print.Decoder + Elm.Print.Encoder + Elm.Print.Types + + build-depends: aeson >= 1.3 + , directory ^>= 1.3 + , filepath ^>= 1.4 + , prettyprinter ^>= 1.2.1 + , text ^>= 1.2 + , time + library types + import: common-options hs-source-dirs: types exposed-modules: Types - build-depends: base >= 4.11 && < 4.13 - , aeson + build-depends: aeson , elm-street , text , time - ghc-options: -Wall - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wcompat - -Widentities - -Wredundant-constraints - -fhide-source-paths - -Wmissing-export-lists - -Wpartial-fields - - default-language: Haskell2010 - default-extensions: ConstraintKinds - DeriveGeneric - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - executable generate-elm + import: common-options hs-source-dirs: generate-elm main-is: Main.hs - build-depends: base - , elm-street + build-depends: elm-street , types + , directory + , filepath + , text - ghc-options: -Wall - -threaded + ghc-options: -threaded -rtsopts -with-rtsopts=-N - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wcompat - -Widentities - -Wredundant-constraints - -fhide-source-paths - default-language: Haskell2010 - executable run-backend + import: common-options hs-source-dirs: backend main-is: Main.hs other-modules: Api - build-depends: base - , servant >= 0.14 && < 0.17 + build-depends: servant >= 0.14 && < 0.17 , servant-server >= 0.14 && < 0.17 , types , wai ^>= 3.2 , warp ^>= 3.2 - ghc-options: -Wall - -threaded + ghc-options: -threaded -rtsopts -with-rtsopts=-N - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wcompat - -Widentities - -Wredundant-constraints - -fhide-source-paths - default-language: Haskell2010 - default-extensions: ConstraintKinds - DeriveGeneric - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeOperators - ViewPatterns - test-suite elm-street-test + import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - - build-depends: base >= 4.11.1.0 && < 4.13 - , elm-street + other-modules: Test.Golden + build-depends: elm-street + , types + , aeson + , bytestring ^>= 0.10 + , hspec ^>= 2.7.1 - ghc-options: -Wall - -threaded + ghc-options: -threaded -rtsopts -with-rtsopts=-N - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wcompat - -Widentities - -Wredundant-constraints - -fhide-source-paths - -Wmissing-export-lists - -Wpartial-fields - - default-language: Haskell2010 - default-extensions: ConstraintKinds - DeriveGeneric - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns diff --git a/generate-elm/Main.hs b/generate-elm/Main.hs --- a/generate-elm/Main.hs +++ b/generate-elm/Main.hs @@ -7,9 +7,42 @@ module Main (main) where +import Data.Text (Text) import Elm (defaultSettings, generateElm) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) import Types (Types) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + main :: IO () -main = generateElm @Types $ defaultSettings "frontend/src" ["Core"] +main = do + -- Generate Types, Encoders, Decoders + generateElm @Types $ defaultSettings "frontend/src" ["Core"] + + -- Generate JSON string in Elm files for testing purposes + golden <- TIO.readFile "test/golden/oneType.json" + generateGoldenType golden + +{- | +1. Reads the JSON file created for testing: @test/golden/oneType.json@ +2. Creates Elm module with the function that is the string of the read content. + This file can be found at @frontend/tests/Tests/Golden.elm@. +-} +generateGoldenType :: Text -> IO () +generateGoldenType c = do + let path = "frontend/tests/Tests" + createDirectoryIfMissing True path + TIO.writeFile (path "Golden.elm") golden + where + golden :: Text + golden = T.unlines $ + [ "module Tests.Golden exposing (goldenOneTypeJson)" + , "" + , "goldenOneTypeJson : String" + , "goldenOneTypeJson =" + ] ++ map (" " <>) + ( "\"\"\"" : T.lines c ++ [ "\"\"\"" ] + ) diff --git a/src/Elm/Aeson.hs b/src/Elm/Aeson.hs --- a/src/Elm/Aeson.hs +++ b/src/Elm/Aeson.hs @@ -133,6 +133,7 @@ elmStreetJsonOptions :: forall a . Typeable a => Options elmStreetJsonOptions = defaultOptions { fieldLabelModifier = T.unpack . stripTypeNamePrefix typeName . T.pack + , tagSingleConstructors = True } where typeName :: TypeName diff --git a/src/Elm/Ast.hs b/src/Elm/Ast.hs --- a/src/Elm/Ast.hs +++ b/src/Elm/Ast.hs @@ -72,18 +72,19 @@ -- | Primitive elm types; hardcoded by the language. data ElmPrim - = ElmUnit -- ^ @()@ type in elm - | ElmNever -- ^ @Never@ type in elm, analogous to Void in Haskell - | ElmBool -- ^ @Bool@ - | ElmChar -- ^ @Char@ - | ElmInt -- ^ @Int@ - | ElmFloat -- ^ @Float@ - | ElmString -- ^ @String@ - | ElmTime -- ^ @Posix@ in elm, @UTCTime@ in Haskell - | ElmMaybe !TypeRef -- ^ @Maybe T@ - | ElmResult !TypeRef !TypeRef -- ^ @Result A B@ in elm - | ElmPair !TypeRef !TypeRef -- ^ @(A, B)@ in elm - | ElmList !TypeRef -- ^ @List A@ in elm + = ElmUnit -- ^ @()@ type in elm + | ElmNever -- ^ @Never@ type in elm, analogous to Void in Haskell + | ElmBool -- ^ @Bool@ + | ElmChar -- ^ @Char@ + | ElmInt -- ^ @Int@ + | ElmFloat -- ^ @Float@ + | ElmString -- ^ @String@ + | ElmTime -- ^ @Posix@ in elm, @UTCTime@ 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 deriving (Show) -- | Reference to another existing type. diff --git a/src/Elm/Generate.hs b/src/Elm/Generate.hs --- a/src/Elm/Generate.hs +++ b/src/Elm/Generate.hs @@ -22,8 +22,8 @@ import System.FilePath ((<.>), ()) import Elm.Generic (Elm (..)) -import Elm.Print (decodeChar, decodeEither, decodeEnum, decodePair, encodeEither, encodeMaybe, - encodePair, prettyShowDecoder, prettyShowDefinition, prettyShowEncoder) +import Elm.Print (decodeChar, decodeEither, decodeEnum, decodePair, decodeTriple, encodeEither, encodeMaybe, + encodePair, encodeTriple, prettyShowDecoder, prettyShowDefinition, prettyShowEncoder) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -133,7 +133,7 @@ , "import Json.Encode as E exposing (..)" , "" , "import " <> streetModule <> " exposing (..)" - , "import " <> typesModule <> " exposing (..)" + , "import " <> typesModule <> " as T" ] decoderHeader :: Text @@ -145,7 +145,7 @@ , "import Json.Decode.Pipeline as D exposing (required)" , "" , "import " <> streetModule <> " exposing (..)" - , "import " <> typesModule <> " exposing (..)" + , "import " <> typesModule <> " as T" ] elmStreetDefinitions :: [Text] @@ -160,9 +160,11 @@ , encodeMaybe , encodeEither , encodePair + , encodeTriple , decodeEnum , decodeChar , decodeEither , decodePair + , decodeTriple ] diff --git a/src/Elm/Generic.hs b/src/Elm/Generic.hs --- a/src/Elm/Generic.hs +++ b/src/Elm/Generic.hs @@ -58,10 +58,10 @@ 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 GHC.TypeNats (type (+), type (<=?)) import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), definitionToRef) @@ -115,8 +115,6 @@ instance Elm Float where toElmDefinition _ = DefPrim ElmFloat instance Elm Double where toElmDefinition _ = DefPrim ElmFloat -instance {-# OVERLAPPING #-} Elm String where toElmDefinition _ = DefPrim ElmString - instance Elm Text where toElmDefinition _ = DefPrim ElmString instance Elm LT.Text where toElmDefinition _ = DefPrim ElmString @@ -135,6 +133,9 @@ instance (Elm a, Elm b) => Elm (a, b) where toElmDefinition _ = DefPrim $ ElmPair (elmRef @a) (elmRef @b) + +instance (Elm a, Elm b, Elm c) => Elm (a, b, c) where + toElmDefinition _ = DefPrim $ ElmTriple (elmRef @a) (elmRef @b) (elmRef @c) instance Elm a => Elm [a] where toElmDefinition _ = DefPrim $ ElmList (elmRef @a) diff --git a/src/Elm/Print.hs b/src/Elm/Print.hs --- a/src/Elm/Print.hs +++ b/src/Elm/Print.hs @@ -3,670 +3,16 @@ -} module Elm.Print - ( prettyShowDefinition - , prettyShowEncoder - , prettyShowDecoder - - -- * Standard missing encoders - , encodeMaybe - , encodeEither - , encodePair - - -- * Standard missing decoders - , decodeEnum - , decodeChar - , decodeEither - , decodePair - - -- * Internal functions - , elmAliasDoc - , elmTypeDoc + ( module Elm.Print.Common + , module Elm.Print.Decoder + , module Elm.Print.Encoder + , module Elm.Print.Types ) where -import Data.List.NonEmpty (NonEmpty ((:|)), toList) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, align, brackets, colon, comma, concatWith, dquotes, emptyDoc, - equals, lbrace, lbracket, line, lparen, nest, parens, pipe, - pretty, prettyList, rbrace, rbracket, rparen, sep, space, - surround, vsep, (<+>)) - -import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), - ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), getConstructorNames, - isEnum) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T - - -{- | Pretty shows Elm types. - -* See 'elmAliasDoc' for examples of generated @type alias@. -* See 'elmTypeDoc' for examples of generated @type@. --} -prettyShowDefinition :: ElmDefinition -> Text -prettyShowDefinition = showDoc . elmDoc - -showDoc :: Doc ann -> Text -showDoc = T.pack . show - -elmDoc :: ElmDefinition -> Doc ann -elmDoc = \case - DefAlias elmAlias -> elmAliasDoc elmAlias - DefType elmType -> elmTypeDoc elmType - DefPrim _ -> emptyDoc - --- | Pretty printer for type reference. -elmTypeRefDoc :: TypeRef -> Doc ann -elmTypeRefDoc = \case - RefPrim elmPrim -> elmPrimDoc elmPrim - RefCustom (TypeName typeName) -> pretty typeName - -{- | Pretty printer for primitive Elm types. This pretty printer is used only to -display types of fields. --} -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 - ElmList l -> "List" <+> elmTypeParenDoc l - -{- | Pretty-printer for types. Adds parens for both sides when needed (when type -contains of multiple words). --} -elmTypeParenDoc :: TypeRef -> Doc ann -elmTypeParenDoc = wrapParens . elmTypeRefDoc - -{- | Wraps given document in parens if it contains more than single word. --} -wrapParens :: Doc ann -> Doc ann -wrapParens = wordsDoc . T.words . showDoc - where - wordsDoc :: [Text] -> Doc ann - wordsDoc = \case - [] -> "" - [x] -> pretty x - xs -> lparen <> pretty (T.unwords xs) <> rparen - -{- | Pretty printer for Elm aliases: - -@ -type alias User = - { userHeh : String - , userMeh : Int - } -@ --} -elmAliasDoc :: ElmAlias -> Doc ann -elmAliasDoc ElmAlias{..} = nest 4 $ - vsep $ ("type alias" <+> pretty elmAliasName <+> equals) - : fieldsDoc elmAliasFields - where - fieldsDoc :: NonEmpty ElmRecordField -> [Doc ann] - fieldsDoc (fstR :| rest) = - lbrace <+> recordFieldDoc fstR - : map ((comma <+>) . recordFieldDoc) rest - ++ [rbrace] - - recordFieldDoc :: ElmRecordField -> Doc ann - recordFieldDoc ElmRecordField{..} = - pretty elmRecordFieldName - <+> colon - <+> elmTypeRefDoc elmRecordFieldType - -{- | Pretty printer for Elm types with one or more constructors: - -@ -type Status a - = Foo String Int - | Bar a - | Baz -@ - -If the type is a newtype then additionally @unTYPENAME@ function is generated: - -@ -type Id a - = Id String - -unId : Id a -> String -unId (Id x) = x -@ - -If the type is Enum this function will add enum specific functions: - -@ -type Status - = Approved - | Yoyoyo - | Wow - -showStatus : Status -> String -showStatus x = case x of - Approved -> "Approved" - Yoyoyo -> "Yoyoyo" - Wow -> "Wow" - -readStatus : String -> Maybe Status -readStatus x = case x of - "Approved" -> Just Approved - "Yoyoyo" -> Just Yoyoyo - "Wow" -> Just Wow - _ -> Nothing - -universeStatus : List Status -universeStatus = [Approved, Yoyoyo, Wow] -@ --} -elmTypeDoc :: ElmType -> Doc ann -elmTypeDoc t@ElmType{..} = - nest 4 ( vsep $ ("type" <+> pretty elmTypeName <> sepVars) - : constructorsDoc elmTypeConstructors - ) - <> unFunc - <> enumFuncs - where - sepVars :: Doc ann - sepVars = case elmTypeVars of - [] -> emptyDoc - vars -> space <> sep (map pretty vars) - - constructorsDoc :: NonEmpty ElmConstructor -> [Doc ann] - constructorsDoc (fstC :| rest) = - equals <+> constructorDoc fstC - : map ((pipe <+>) . constructorDoc) rest - - constructorDoc :: ElmConstructor -> Doc ann - constructorDoc ElmConstructor{..} = sep $ - pretty elmConstructorName : map elmTypeRefDoc elmConstructorFields - - -- Generates 'unTYPENAME' function for newtype - unFunc :: Doc ann - unFunc = - if elmTypeIsNewtype - then line <> elmUnFuncDoc t - else emptyDoc - - enumFuncs :: Doc ann - enumFuncs = - if isEnum t - then vsep $ map (line <>) [elmEnumShowDoc t, elmEnumReadDoc t, elmEnumUniverse t] - else emptyDoc - -elmUnFuncDoc :: ElmType -> Doc ann -elmUnFuncDoc ElmType{..} = line <> vsep - [ unName <+> colon <+> typeWithVarsDoc elmTypeName elmTypeVars <+> arrow <+> result - , unName <+> parens (ctorName <+> "x") <+> equals <+> "x" - ] - where - unName :: Doc ann - unName = "un" <> pretty elmTypeName - - ctor :: ElmConstructor - ctor = NE.head elmTypeConstructors - - result :: Doc ann - result = case elmConstructorFields ctor of - [] -> "ERROR" - fld : _ -> elmTypeRefDoc fld - - ctorName :: Doc ann - ctorName = pretty $ elmConstructorName ctor - -elmEnumShowDoc :: forall ann . ElmType -> Doc ann -elmEnumShowDoc t@ElmType{..} = - line - -- function type - <> (showName <+> colon <+> pretty elmTypeName <+> arrow <+> "String") - <> line - -- function body - <> nest 4 - ( vsep $ (showName <+> "x" <+> equals <+> "case x of") - -- pattern matching - : map patternMatch (getConstructorNames t) - ) - where - showName :: Doc ann - showName = "show" <> pretty elmTypeName - - patternMatch :: Text -> Doc ann - patternMatch (pretty -> c) = c <+> arrow <+> dquotes c - -elmEnumReadDoc :: ElmType -> Doc ann -elmEnumReadDoc t@ElmType{..} = - -- function type - (readName <+> colon <+> "String" <+> arrow <+> "Maybe" <+> pretty elmTypeName) - <> line - -- function body - <> nest 4 - ( vsep $ (readName <+> "x" <+> equals <+> "case x of") - -- pattern matching - : map patternMatch (getConstructorNames t) - ++ ["_" <+> arrow <+> "Nothing"] - ) - where - readName :: Doc ann - readName = "read" <> pretty elmTypeName - - patternMatch :: Text -> Doc ann - patternMatch (pretty -> c) = dquotes c <+> arrow <+> "Just" <+> c - -elmEnumUniverse :: ElmType -> Doc ann -elmEnumUniverse t@ElmType{..} = vsep - -- function type - [ universeName <+> colon <+> "List" <+> pretty elmTypeName - , universeName <+> equals <+> align (prettyList $ getConstructorNames t) - ] - where - universeName :: Doc ann - universeName = "universe" <> pretty elmTypeName - -arrow :: Doc ann -arrow = "->" - ----------------------------------------------------------------------------- --- Encode ----------------------------------------------------------------------------- - -{- | Returns the encoder for the given type. - - -TODO - +-------------------+------------------+-----------------+---------------------+ - | Haskell Type | Eml Type | Encoder | JSON | - +===================+==================+=================+=====================+ - | 'Int' | 'Int' | standard encoder | | - +-------------------+------------------+------------------+--------------------+ - --} -prettyShowEncoder :: ElmDefinition -> Text -prettyShowEncoder def = showDoc $ case def of - DefAlias elmAlias -> aliasEncoderDoc elmAlias - 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@. - encoderDef elmTypeName elmTypeVars - <> line - <> if isEnum t - -- if this is Enum just using the show instance we wrote. - then enumEncoder - 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]}@ - else sumEncoder - where - enumEncoder :: Doc ann - enumEncoder = name <+> equals <+> "E.string << show" <> pretty elmTypeName - - newtypeEncoder :: Doc ann - newtypeEncoder = - name <+> equals <+> fieldEncoderDoc <+> "<< un" <> pretty elmTypeName - where - fieldEncoderDoc :: Doc ann - fieldEncoderDoc = case elmConstructorFields $ NE.head elmTypeConstructors of - [] -> "ERROR" - f : _ -> typeRefEncoder f - - sumEncoder :: Doc ann - sumEncoder = nest 4 - $ vsep - $ (name <+> "x" <+> equals <+> "E.object <| case x of") - : map mkCase (toList elmTypeConstructors) - - -- | Encoder function name - name :: Doc ann - name = encoderName elmTypeName - - -- | Create case clouse for each of the sum Constructors. - mkCase :: ElmConstructor -> Doc ann - mkCase ElmConstructor{..} = - conName <+> vars <+> arrow - <+> brackets (parens (dquotes "tag" <> comma <+> "E.string" <+> dquotes conName) <> contents) - where - -- | Constructor name - conName :: Doc ann - conName = pretty elmConstructorName - - -- | 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..] - - contents :: Doc ann - contents = "," <+> parens (dquotes "contents" <> comma <+> contentsEnc) - - -- JSON encoder for the "contents" key - contentsEnc :: Doc ann - contentsEnc = case elmConstructorFields of - [_] -> fieldEncs - _ -> "E.list identity" <+> brackets fieldEncs - - -- | @encoderA x1@ - fieldEncs :: Doc ann - fieldEncs = concatWith (surround ", ") $ - zipWith (<+>) (map typeRefEncoder elmConstructorFields) fields - - -- | Makes variable like: @x11@ etc. - mkText :: Text -> Int -> Text - mkText x i = x <> T.pack (show i) - - vars :: Doc ann - vars = concatWith (surround " ") fields - - -aliasEncoderDoc :: ElmAlias -> Doc ann -aliasEncoderDoc ElmAlias{..} = - encoderDef elmAliasName [] - <> line - <> if elmAliasIsNewtype - then newtypeEncoder - else recordEncoder - where - newtypeEncoder :: Doc ann - newtypeEncoder = leftPart <+> fieldEncoderDoc (NE.head elmAliasFields) - - recordEncoder :: Doc ann - recordEncoder = nest 4 - $ vsep - $ (leftPart <+> "E.object") - : fieldsEncode elmAliasFields - - leftPart :: Doc ann - leftPart = encoderName elmAliasName <+> "x" <+> equals - - fieldsEncode :: NonEmpty ElmRecordField -> [Doc ann] - fieldsEncode (fstR :| rest) = - lbracket <+> recordFieldDoc fstR - : map ((comma <+>) . recordFieldDoc) rest - ++ [rbracket] - - recordFieldDoc :: ElmRecordField -> Doc ann - recordFieldDoc field@ElmRecordField{..} = parens $ - dquotes (pretty elmRecordFieldName) - <> comma - <+> fieldEncoderDoc field - - fieldEncoderDoc :: ElmRecordField -> Doc ann - fieldEncoderDoc ElmRecordField{..} = - typeRefEncoder elmRecordFieldType <+> "x." <> pretty elmRecordFieldName - --- | The definition of the @encodeTYPENAME@ function. -encoderDef - :: Text -- ^ Type name - -> [Text] -- ^ List of type variables - -> Doc ann -encoderDef typeName vars = - encoderName typeName <+> colon <+> typeWithVarsDoc typeName vars <+> arrow <+> "Value" - -typeWithVarsDoc - :: Text -- ^ Type name - -> [Text] -- ^ List of type variables - -> Doc ann -typeWithVarsDoc typeName = \case - [] -> pretty typeName - vars -> pretty typeName <+> typeVarsDoc vars - where - typeVarsDoc :: [Text] -> Doc ann - typeVarsDoc = concatWith (surround " ") . map pretty - --- | Create the name of the encoder function. -encoderName :: Text -> Doc ann -encoderName typeName = "encode" <> pretty typeName - --- | Converts the reference to the existing type to the corresponding encoder. -typeRefEncoder :: TypeRef -> Doc ann -typeRefEncoder (RefCustom TypeName{..}) = "encode" <> pretty (T.takeWhile (/= ' ') unTypeName) -typeRefEncoder (RefPrim elmPrim) = case elmPrim of - ElmUnit -> "(always <| E.list identity [])" - ElmNever -> "never" - ElmBool -> "E.bool" - ElmChar -> parens "E.string << String.fromChar" - ElmInt -> "E.int" - ElmFloat -> "E.float" - ElmString -> "E.string" - ElmTime -> "Iso.encode" - ElmMaybe t -> parens $ "elmStreetEncodeMaybe" <+> typeRefEncoder t - ElmResult l r -> parens $ "elmStreetEncodeEither" <+> typeRefEncoder l <+> typeRefEncoder r - ElmPair a b -> parens $ "elmStreetEncodePair" <+> typeRefEncoder a <+> typeRefEncoder b - ElmList l -> "E.list" <+> typeRefEncoder l - -encodeMaybe :: Text -encodeMaybe = T.unlines - [ "elmStreetEncodeMaybe : (a -> Value) -> Maybe a -> Value" - , "elmStreetEncodeMaybe enc = Maybe.withDefault E.null << Maybe.map enc" - ] - -encodeEither :: Text -encodeEither = T.unlines - [ "elmStreetEncodeEither : (a -> Value) -> (b -> Value) -> Result a b -> Value" - , "elmStreetEncodeEither encA encB res = E.object <| case res of" - , " Err a -> [(\"Left\", encA a)]" - , " Ok b -> [(\"Right\", encB b)]" - ] - -encodePair :: Text -encodePair = T.unlines - [ "elmStreetEncodePair : (a -> Value) -> (b -> Value) -> (a, b) -> Value" - , "elmStreetEncodePair encA encB (a, b) = E.list identity [encA a, encB b]" - ] - ----------------------------------------------------------------------------- --- Decode ----------------------------------------------------------------------------- - -{- | - -**Sum Types:** - -Haskell type - -@ -type User - = Foo - | Bar String Int -@ - -Encoded JSON on Haskell side - -@ - [ { "tag" : "Foo" - } - , { "tag" : "Bar" - , "contents" : ["asd", 42, "qwerty"] - } - ] -@ - -Elm decoder - -@ -userDecoder : Decoder User -userDecoder = - let decide : String -> Decoder User - decide x = case x of - "Foo" -> D.succeed Foo - "Bar" -> D.field "contents" <| D.map2 Bar (D.index 0 D.string) (D.index 1 D.int) - x -> D.fail <| "There is no constructor for User type:" ++ x - in D.andThen decide (D.field "tag" D.string) -@ - --} -prettyShowDecoder :: ElmDefinition -> Text -prettyShowDecoder def = showDoc $ case def of - DefAlias elmAlias -> aliasDecoderDoc elmAlias - DefType elmType -> typeDecoderDoc elmType - DefPrim _ -> emptyDoc - -aliasDecoderDoc :: ElmAlias -> Doc ann -aliasDecoderDoc ElmAlias{..} = - decoderDef elmAliasName [] - <> line - <> if elmAliasIsNewtype - then newtypeDecoder - else recordDecoder - where - newtypeDecoder :: Doc ann - newtypeDecoder = name <+> "D.map" <+> aliasName - <+> typeRefDecoder (elmRecordFieldType $ NE.head elmAliasFields) - - recordDecoder :: Doc ann - recordDecoder = nest 4 - $ vsep - $ (name <+> "D.succeed" <+> aliasName) - : map fieldDecode (toList elmAliasFields) - - name :: Doc ann - name = decoderName elmAliasName <+> equals - - aliasName :: Doc ann - aliasName = pretty elmAliasName - - fieldDecode :: ElmRecordField -> Doc ann - fieldDecode ElmRecordField{..} = case elmRecordFieldType of - RefPrim ElmUnit -> "|> D.hardcoded ()" - t -> "|> required" - <+> dquotes (pretty elmRecordFieldName) - <+> typeRefDecoder t - -typeDecoderDoc :: ElmType -> Doc ann -typeDecoderDoc t@ElmType{..} = - -- function defenition: @encodeTypeName : TypeName -> Value@. - decoderDef elmTypeName elmTypeVars - <> line - <> if isEnum t - -- if this is Enum just using the read instance we wrote. - then enumDecoder - else if elmTypeIsNewtype - -- if it newtype then wrap decoder for the field - then newtypeDecoder - -- If it sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@ - else sumDecoder - where - name :: Doc ann - name = decoderName elmTypeName <+> equals - - typeName :: Doc ann - typeName = pretty elmTypeName - - enumDecoder :: Doc ann - enumDecoder = name <+> "elmStreetDecodeEnum read" <> typeName - - newtypeDecoder :: Doc ann - newtypeDecoder = name <+> "D.map" <+> typeName <+> fieldDecoderDoc - where - fieldDecoderDoc :: Doc ann - fieldDecoderDoc = case elmConstructorFields $ NE.head elmTypeConstructors of - [] -> "(D.fail \"Unknown field type of the newtype constructor\")" - f : _ -> typeRefDecoder f - - sumDecoder :: Doc ann - sumDecoder = nest 4 $ vsep - [ name - , nest 4 (vsep $ ("let decide : String -> Decoder" <+> typeName) : - [ nest 4 - ( vsep $ "decide x = case x of" - : map cases (toList elmTypeConstructors) - ++ ["c -> D.fail <|" <+> dquotes (typeName <+> "doesn't have such constructor: ") <+> "++ c"] - ) - ]) - , "in D.andThen decide (D.field \"tag\" D.string)" - ] - - cases :: ElmConstructor -> Doc ann - cases ElmConstructor{..} = dquotes cName <+> arrow <+> - case elmConstructorFields of - [] -> "D.succeed" <+> cName - [f] -> "D.field \"contents\" <| D.map" <+> cName <+> typeRefDecoder f - l -> "D.field \"contents\" <| D.map" <> mapNum (length l) <+> cName <+> createIndexes - where - cName :: Doc ann - cName = pretty elmConstructorName - - -- Use function map, map2, map3 etc. - mapNum :: Int -> Doc ann - mapNum 1 = emptyDoc - mapNum i = pretty i - - createIndexes :: Doc ann - createIndexes = concatWith (surround " ") $ zipWith oneField [0..] elmConstructorFields - - -- create @(D.index 0 D.string)@ etc. - oneField :: Int -> TypeRef -> Doc ann - oneField i typeRef = parens $ "D.index" <+> pretty i <+> typeRefDecoder typeRef - --- | Converts the reference to the existing type to the corresponding decoder. -typeRefDecoder :: TypeRef -> Doc ann -typeRefDecoder (RefCustom TypeName{..}) = "decode" <> pretty (T.takeWhile (/= ' ') unTypeName) -typeRefDecoder (RefPrim elmPrim) = case elmPrim of - ElmUnit -> "(D.hardcoded ())" - ElmNever -> "(D.fail \"Never is not possible\")" - ElmBool -> "D.bool" - ElmChar -> "elmStreetDecodeChar" - ElmInt -> "D.int" - ElmFloat -> "D.float" - ElmString -> "D.string" - ElmTime -> "Iso.decoder" - ElmMaybe t -> parens $ "nullable" <+> typeRefDecoder t - ElmResult l r -> parens $ "elmStreetDecodeEither" <+> typeRefDecoder l <+> typeRefDecoder r - ElmPair a b -> parens $ "elmStreetDecodePair" <+> typeRefDecoder a <+> typeRefDecoder b - ElmList l -> parens $ "D.list" <+> typeRefDecoder l - --- | The definition of the @encodeTYPENAME@ function. -decoderDef - :: Text -- ^ Type name - -> [Text] -- ^ List of type variables - -> Doc ann -decoderDef typeName vars = - decoderName typeName <+> colon <+> "Decoder" <+> wrapParens (typeWithVarsDoc typeName vars) - --- | Create the name of the decoder function. -decoderName :: Text -> Doc ann -decoderName typeName = "decode" <> pretty typeName - -decodeEnum :: Text -decodeEnum = T.unlines - [ "decodeStr : (String -> Maybe a) -> String -> Decoder a" - , "decodeStr readX x = case readX x of" - , " Just a -> D.succeed a" - , " Nothing -> D.fail \"Constructor not matched\"" - , "" - , "elmStreetDecodeEnum : (String -> Maybe a) -> Decoder a" - , "elmStreetDecodeEnum r = D.andThen (decodeStr r) D.string" - ] - -decodeChar :: Text -decodeChar = T.unlines - [ "elmStreetDecodeChar : Decoder Char" - , "elmStreetDecodeChar = D.andThen (decodeStr (Maybe.map Tuple.first << String.uncons)) D.string" - ] - -decodeEither :: Text -decodeEither = T.unlines - [ "elmStreetDecodeEither : Decoder a -> Decoder b -> Decoder (Result a b)" - , "elmStreetDecodeEither decA decB = D.oneOf " - , " [ D.field \"Left\" (D.map Err decA)" - , " , D.field \"Right\" (D.map Ok decB)" - , " ]" - ] - -decodePair :: Text -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)" - ] +import Elm.Print.Common +import Elm.Print.Decoder +import Elm.Print.Encoder +import Elm.Print.Types {- putStrLn $ T.unpack $ prettyShowDefinition $ DefAlias $ ElmAlias "User" $ (ElmRecordField (TypeName "String") "userHeh") :| [ElmRecordField (TypeName "Int") "userMeh"] diff --git a/src/Elm/Print/Common.hs b/src/Elm/Print/Common.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Print/Common.hs @@ -0,0 +1,63 @@ +{- | This module contains some commonly used function for working +with 'Doc's and pretty printing. +-} + +module Elm.Print.Common + ( showDoc + , wrapParens + , arrow + , mkQualified + , typeWithVarsDoc + ) where + +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc, concatWith, lparen, pretty, rparen, surround, (<+>)) + +import qualified Data.Text as T + + +-- | Shows pretty-printed document. +showDoc :: Doc ann -> Text +showDoc = T.pack . show + +{- | Wraps given document in parens if it contains more than single word. +-} +wrapParens :: Doc ann -> Doc ann +wrapParens = wordsDoc . T.words . showDoc + where + wordsDoc :: [Text] -> Doc ann + wordsDoc = \case + [] -> "" + [x] -> pretty x + xs -> lparen <> pretty (T.unwords xs) <> rparen + +-- | Pretty printed arrow (@->@). +arrow :: Doc ann +arrow = "->" + +{- | Add qualified prefix to the type names or functions: + +@ +T.MyType + +T.showMyType +@ + +Here we add @T.@ prefix as we only use qualified imports +for @Types as T@ module. +-} +mkQualified :: Text -> Doc ann +mkQualified = pretty . ("T." <>) + +{- | Creates a 'Doc' of the qualified type with its type variables (if any). +-} +typeWithVarsDoc + :: Text -- ^ Type name + -> [Text] -- ^ List of type variables + -> Doc ann +typeWithVarsDoc (mkQualified -> qTypeName) = \case + [] -> qTypeName + vars -> qTypeName <+> typeVarsDoc vars + where + typeVarsDoc :: [Text] -> Doc ann + typeVarsDoc = concatWith (surround " ") . map pretty diff --git a/src/Elm/Print/Decoder.hs b/src/Elm/Print/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Print/Decoder.hs @@ -0,0 +1,250 @@ +{- | Pretty-printing functions for @Decoder.elm@ module. +Also contains decoders for common types which go to the @ElmStreet.elm@ module. +-} + +module Elm.Print.Decoder + ( prettyShowDecoder + + -- * Standard missing decoders + , decodeEnum + , decodeChar + , decodeEither + , decodePair + , decodeTriple + ) where + +import Data.List.NonEmpty (toList) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc, colon, concatWith, dquotes, emptyDoc, equals, line, nest, + parens, pretty, surround, vsep, (<+>)) + +import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), + ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), isEnum) +import Elm.Print.Common (arrow, mkQualified, showDoc, typeWithVarsDoc, wrapParens) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T + + +---------------------------------------------------------------------------- +-- Decode +---------------------------------------------------------------------------- + +{- | + +__Sum Types:__ + +Haskell type + +@ +type User + = Foo + | Bar String Int +@ + +Encoded JSON on Haskell side + +@ + [ { "tag" : "Foo" + } + , { "tag" : "Bar" + , "contents" : ["asd", 42, "qwerty"] + } + ] +@ + +Elm decoder + +@ +userDecoder : Decoder User +userDecoder = + let decide : String -> Decoder User + decide x = case x of + \"Foo\" -> D.succeed Foo + \"Bar\" -> D.field "contents" <| D.map2 Bar (D.index 0 D.string) (D.index 1 D.int) + x -> D.fail <| "There is no constructor for User type:" ++ x + in D.andThen decide (D.field "tag" D.string) +@ + +-} +prettyShowDecoder :: ElmDefinition -> Text +prettyShowDecoder def = showDoc $ case def of + DefAlias elmAlias -> aliasDecoderDoc elmAlias + DefType elmType -> typeDecoderDoc elmType + DefPrim _ -> emptyDoc + +aliasDecoderDoc :: ElmAlias -> Doc ann +aliasDecoderDoc ElmAlias{..} = + decoderDef elmAliasName [] + <> line + <> if elmAliasIsNewtype + then newtypeDecoder + else recordDecoder + where + newtypeDecoder :: Doc ann + newtypeDecoder = name <+> "D.map" <+> qualifiedAliasName + <+> typeRefDecoder (elmRecordFieldType $ NE.head elmAliasFields) + + recordDecoder :: Doc ann + recordDecoder = nest 4 + $ vsep + $ (name <+> "D.succeed" <+> qualifiedAliasName) + : map fieldDecode (toList elmAliasFields) + + name :: Doc ann + name = decoderName elmAliasName <+> equals + + qualifiedAliasName :: Doc ann + qualifiedAliasName = mkQualified elmAliasName + + fieldDecode :: ElmRecordField -> Doc ann + fieldDecode ElmRecordField{..} = case elmRecordFieldType of + RefPrim ElmUnit -> "|> D.hardcoded ()" + t -> "|> required" + <+> dquotes (pretty elmRecordFieldName) + <+> typeRefDecoder t + +typeDecoderDoc :: ElmType -> Doc ann +typeDecoderDoc t@ElmType{..} = + -- function defenition: @encodeTypeName : TypeName -> Value@. + decoderDef elmTypeName elmTypeVars + <> line + <> if isEnum t + -- if this is Enum just using the read instance we wrote. + then enumDecoder + else if elmTypeIsNewtype + -- if it newtype then wrap decoder for the field + then newtypeDecoder + -- If it sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@ + else sumDecoder + where + name :: Doc ann + name = decoderName elmTypeName <+> equals + + typeName :: Doc ann + typeName = pretty elmTypeName + + qualifiedTypeName :: Doc ann + qualifiedTypeName = mkQualified elmTypeName + + enumDecoder :: Doc ann + enumDecoder = name <+> "elmStreetDecodeEnum T.read" <> typeName + + newtypeDecoder :: Doc ann + newtypeDecoder = name <+> "D.map" <+> qualifiedTypeName <+> fieldDecoderDoc + where + fieldDecoderDoc :: Doc ann + fieldDecoderDoc = case elmConstructorFields $ NE.head elmTypeConstructors of + [] -> "(D.fail \"Unknown field type of the newtype constructor\")" + f : _ -> typeRefDecoder f + + sumDecoder :: Doc ann + sumDecoder = nest 4 $ vsep + [ name + , nest 4 (vsep $ ("let decide : String -> Decoder" <+> qualifiedTypeName) : + [ nest 4 + ( vsep $ "decide x = case x of" + : map cases (toList elmTypeConstructors) + ++ ["c -> D.fail <|" <+> dquotes (typeName <+> "doesn't have such constructor: ") <+> "++ c"] + ) + ]) + , "in D.andThen decide (D.field \"tag\" D.string)" + ] + + cases :: ElmConstructor -> Doc ann + cases ElmConstructor{..} = dquotes cName <+> arrow <+> + case elmConstructorFields of + [] -> "D.succeed" <+> qualifiedConName + [f] -> "D.field \"contents\" <| D.map" <+> qualifiedConName <+> typeRefDecoder f + l -> "D.field \"contents\" <| D.map" <> mapNum (length l) <+> qualifiedConName <+> createIndexes + where + cName :: Doc ann + cName = pretty elmConstructorName + + qualifiedConName :: Doc ann + qualifiedConName = mkQualified elmConstructorName + + -- Use function map, map2, map3 etc. + mapNum :: Int -> Doc ann + mapNum 1 = emptyDoc + mapNum i = pretty i + + createIndexes :: Doc ann + createIndexes = concatWith (surround " ") $ zipWith oneField [0..] elmConstructorFields + + -- create @(D.index 0 D.string)@ etc. + oneField :: Int -> TypeRef -> Doc ann + oneField i typeRef = parens $ "D.index" <+> pretty i <+> typeRefDecoder typeRef + +-- | Converts the reference to the existing type to the corresponding decoder. +typeRefDecoder :: TypeRef -> Doc ann +typeRefDecoder (RefCustom TypeName{..}) = "decode" <> pretty (T.takeWhile (/= ' ') unTypeName) +typeRefDecoder (RefPrim elmPrim) = case elmPrim of + ElmUnit -> "(D.map (always ()) (D.list D.string))" + ElmNever -> "(D.fail \"Never is not possible\")" + ElmBool -> "D.bool" + ElmChar -> "elmStreetDecodeChar" + ElmInt -> "D.int" + ElmFloat -> "D.float" + ElmString -> "D.string" + ElmTime -> "Iso.decoder" + ElmMaybe t -> parens $ "nullable" <+> typeRefDecoder t + ElmResult l r -> parens $ "elmStreetDecodeEither" <+> typeRefDecoder l <+> typeRefDecoder r + ElmPair a b -> parens $ "elmStreetDecodePair" <+> typeRefDecoder a <+> typeRefDecoder b + ElmTriple a b c -> parens $ "elmStreetDecodeTriple" <+> typeRefDecoder a <+> typeRefDecoder b <+> typeRefDecoder c + ElmList l -> parens $ "D.list" <+> typeRefDecoder l + +-- | The definition of the @decodeTYPENAME@ function. +decoderDef + :: Text -- ^ Type name + -> [Text] -- ^ List of type variables + -> Doc ann +decoderDef typeName vars = + decoderName typeName <+> colon <+> "Decoder" <+> wrapParens (typeWithVarsDoc typeName vars) + +-- | Create the name of the decoder function. +decoderName :: Text -> Doc ann +decoderName typeName = "decode" <> pretty typeName + +-- | @JSON@ decoder Elm help function for Enum types. +decodeEnum :: Text +decodeEnum = T.unlines + [ "decodeStr : (String -> Maybe a) -> String -> Decoder a" + , "decodeStr readX x = case readX x of" + , " Just a -> D.succeed a" + , " Nothing -> D.fail \"Constructor not matched\"" + , "" + , "elmStreetDecodeEnum : (String -> Maybe a) -> Decoder a" + , "elmStreetDecodeEnum r = D.andThen (decodeStr r) D.string" + ] + +-- | @JSON@ decoder Elm help function for 'Char's. +decodeChar :: Text +decodeChar = T.unlines + [ "elmStreetDecodeChar : Decoder Char" + , "elmStreetDecodeChar = D.andThen (decodeStr (Maybe.map Tuple.first << String.uncons)) D.string" + ] + +-- | @JSON@ decoder Elm help function for 'Either's. +decodeEither :: Text +decodeEither = T.unlines + [ "elmStreetDecodeEither : Decoder a -> Decoder b -> Decoder (Result a b)" + , "elmStreetDecodeEither decA decB = D.oneOf " + , " [ D.field \"Left\" (D.map Err decA)" + , " , D.field \"Right\" (D.map Ok decB)" + , " ]" + ] + +-- | @JSON@ decoder Elm help function for 2-tuples. +decodePair :: Text +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 3-tuples. +decodeTriple :: Text +decodeTriple = T.unlines + [ "elmStreetDecodeTriple : Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)" + , "elmStreetDecodeTriple decA decB decC = D.map3 (\\a b c -> (a,b,c)) (D.index 0 decA) (D.index 1 decB) (D.index 2 decC)" + ] diff --git a/src/Elm/Print/Encoder.hs b/src/Elm/Print/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Print/Encoder.hs @@ -0,0 +1,216 @@ +{- | Pretty-printing functions for @Encoder.elm@ module. +Also contains encoders for common types which go to the @ElmStreet.elm@ module. +-} + +module Elm.Print.Encoder + ( prettyShowEncoder + + -- * Standard missing encoders + , encodeMaybe + , encodeEither + , encodePair + , encodeTriple + ) 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, + vsep, (<+>)) + +import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), + ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), isEnum) +import Elm.Print.Common (arrow, mkQualified, showDoc, typeWithVarsDoc) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T + + +{- | Returns the encoder for the given type. + + +TODO + + +-------------------+------------------+------------------+--------------------+ + | Haskell Type | Eml Type | Encoder | JSON | + +===================+==================+==================+====================+ + | 'Int' | 'Int' | standard encoder | | + +-------------------+------------------+------------------+--------------------+ + +-} +prettyShowEncoder :: ElmDefinition -> Text +prettyShowEncoder def = showDoc $ case def of + DefAlias elmAlias -> aliasEncoderDoc elmAlias + 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@. + encoderDef elmTypeName elmTypeVars + <> line + <> if isEnum t + -- if this is Enum just using the show instance we wrote. + then enumEncoder + 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]}@ + else sumEncoder + where + enumEncoder :: Doc ann + enumEncoder = name <+> equals <+> "E.string << T.show" <> pretty elmTypeName + + newtypeEncoder :: Doc ann + newtypeEncoder = + name <+> equals <+> fieldEncoderDoc <+> "<< un" <> pretty elmTypeName + where + fieldEncoderDoc :: Doc ann + fieldEncoderDoc = case elmConstructorFields $ NE.head elmTypeConstructors of + [] -> "ERROR" + f : _ -> typeRefEncoder f + + sumEncoder :: Doc ann + sumEncoder = nest 4 + $ vsep + $ (name <+> "x" <+> equals <+> "E.object <| case x of") + : map mkCase (toList elmTypeConstructors) + + -- | Encoder function name + name :: Doc ann + name = encoderName elmTypeName + + -- | Create case clouse for each of the sum Constructors. + mkCase :: ElmConstructor -> Doc ann + mkCase ElmConstructor{..} = mkQualified elmConstructorName + <+> vars + <+> arrow + <+> brackets (mkTag elmConstructorName <> contents) + 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..] + + contents :: Doc ann + contents = "," <+> parens (dquotes "contents" <> comma <+> contentsEnc) + + -- JSON encoder for the "contents" key + contentsEnc :: Doc ann + contentsEnc = case elmConstructorFields of + [_] -> fieldEncs + _ -> "E.list identity" <+> brackets fieldEncs + + -- | @encoderA x1@ + fieldEncs :: Doc ann + fieldEncs = concatWith (surround ", ") $ + zipWith (<+>) (map typeRefEncoder elmConstructorFields) fields + + -- | Makes variable like: @x11@ etc. + mkText :: Text -> Int -> Text + mkText x i = x <> T.pack (show i) + + vars :: Doc ann + vars = concatWith (surround " ") fields + + +aliasEncoderDoc :: ElmAlias -> Doc ann +aliasEncoderDoc ElmAlias{..} = + encoderDef elmAliasName [] + <> line + <> if elmAliasIsNewtype + then newtypeEncoder + else recordEncoder + where + newtypeEncoder :: Doc ann + newtypeEncoder = leftPart <+> fieldEncoderDoc (NE.head elmAliasFields) + + recordEncoder :: Doc ann + recordEncoder = nest 4 + $ vsep + $ (leftPart <+> "E.object") + : fieldsEncode elmAliasFields + + leftPart :: Doc ann + leftPart = encoderName elmAliasName <+> "x" <+> equals + + fieldsEncode :: NonEmpty ElmRecordField -> [Doc ann] + fieldsEncode fields = + lbracket <+> mkTag elmAliasName + : map ((comma <+>) . recordFieldDoc) (NE.toList fields) + ++ [rbracket] + + recordFieldDoc :: ElmRecordField -> Doc ann + recordFieldDoc field@ElmRecordField{..} = parens $ + dquotes (pretty elmRecordFieldName) + <> comma + <+> fieldEncoderDoc field + + fieldEncoderDoc :: ElmRecordField -> Doc ann + fieldEncoderDoc ElmRecordField{..} = + typeRefEncoder elmRecordFieldType <+> "x." <> pretty elmRecordFieldName + +-- | Create pair of view: @("tag", E.string "SomeName")@. +mkTag :: Text -> Doc ann +mkTag txt = parens $ dquotes "tag" <> comma <+> "E.string" <+> dquotes (pretty txt) + +-- | The definition of the @encodeTYPENAME@ function. +encoderDef + :: Text -- ^ Type name + -> [Text] -- ^ List of type variables + -> Doc ann +encoderDef typeName vars = + encoderName typeName <+> colon <+> typeWithVarsDoc typeName vars <+> arrow <+> "Value" + +-- | Create the name of the encoder function. +encoderName :: Text -> Doc ann +encoderName typeName = "encode" <> pretty typeName + +-- | Converts the reference to the existing type to the corresponding encoder. +typeRefEncoder :: TypeRef -> Doc ann +typeRefEncoder (RefCustom TypeName{..}) = "encode" <> pretty (T.takeWhile (/= ' ') unTypeName) +typeRefEncoder (RefPrim elmPrim) = case elmPrim of + ElmUnit -> "(always <| E.list identity [])" + ElmNever -> "never" + ElmBool -> "E.bool" + ElmChar -> parens "E.string << String.fromChar" + ElmInt -> "E.int" + ElmFloat -> "E.float" + ElmString -> "E.string" + ElmTime -> "Iso.encode" + ElmMaybe t -> parens $ "elmStreetEncodeMaybe" <+> typeRefEncoder t + ElmResult l r -> parens $ "elmStreetEncodeEither" <+> typeRefEncoder l <+> typeRefEncoder r + ElmPair a b -> parens $ "elmStreetEncodePair" <+> typeRefEncoder a <+> typeRefEncoder b + ElmTriple a b c -> parens $ "elmStreetEncodeTriple" <+> typeRefEncoder a <+> typeRefEncoder b <+> typeRefEncoder c + ElmList l -> "E.list" <+> typeRefEncoder l + +-- | @JSON@ encoder Elm help function for 'Maybe's. +encodeMaybe :: Text +encodeMaybe = T.unlines + [ "elmStreetEncodeMaybe : (a -> Value) -> Maybe a -> Value" + , "elmStreetEncodeMaybe enc = Maybe.withDefault E.null << Maybe.map enc" + ] + +-- | @JSON@ encoder Elm help function for 'Either's. +encodeEither :: Text +encodeEither = T.unlines + [ "elmStreetEncodeEither : (a -> Value) -> (b -> Value) -> Result a b -> Value" + , "elmStreetEncodeEither encA encB res = E.object <| case res of" + , " Err a -> [(\"Left\", encA a)]" + , " Ok b -> [(\"Right\", encB b)]" + ] + +-- | @JSON@ encoder Elm help function for 2-tuples. +encodePair :: Text +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 3-tuples. +encodeTriple :: Text +encodeTriple = T.unlines + [ "elmStreetEncodeTriple : (a -> Value) -> (b -> Value) -> (c -> Value) -> (a, b, c) -> Value" + , "elmStreetEncodeTriple encA encB encC (a, b, c) = E.list identity [encA a, encB b, encC c]" + ] diff --git a/src/Elm/Print/Types.hs b/src/Elm/Print/Types.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Print/Types.hs @@ -0,0 +1,291 @@ +{- | Pretty functions for `Types.elm` module. + +The generated module should contain: + + * Type definitions for all ADT + * @show*@ functions for Enum types + * @read*@ functions for Enum types + * @universe*@ functions for Enum types + * @un*@ functions for newtypes + +==== __Example__ + +The example of Record, Newtype and Enum generated type and functions: + +@ +type alias User = + { id : Id + , name : String + , age : Age + , status : RequestStatus + } + +type RequestStatus + = Approved + | Rejected + | Reviewing + +showRequestStatus : RequestStatus -> String +showRequestStatus x = case x of + Approved -> \"Approved\" + Rejected -> \"Rejected\" + Reviewing -> \"Reviewing\" + +readRequestStatus : String -> Maybe RequestStatus +readRequestStatus x = case x of + \"Approved\" -> Just Approved + \"Rejected\" -> Just Rejected + \"Reviewing\" -> Just Reviewing + _ -> Nothing + +universeRequestStatus : List RequestStatus +universeRequestStatus = [Approved, Rejected, Reviewing] + +type Id + = Id String + +unId : Id -> String +unId (Id x) = x +@ + +-} + +module Elm.Print.Types + ( prettyShowDefinition + + -- * Internal functions + , elmAliasDoc + , 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, + lparen, nest, parens, pipe, pretty, prettyList, rbrace, rparen, + sep, space, vsep, (<+>)) + +import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), + ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), getConstructorNames, + isEnum) +import Elm.Print.Common (arrow, showDoc, typeWithVarsDoc, wrapParens) + +import qualified Data.List.NonEmpty as NE + + +{- | Pretty shows Elm types. + +* See 'elmAliasDoc' for examples of generated @type alias@. +* See 'elmTypeDoc' for examples of generated @type@. +-} +prettyShowDefinition :: ElmDefinition -> Text +prettyShowDefinition = showDoc . elmDoc + +elmDoc :: ElmDefinition -> Doc ann +elmDoc = \case + DefAlias elmAlias -> elmAliasDoc elmAlias + DefType elmType -> elmTypeDoc elmType + DefPrim _ -> emptyDoc + +-- | Pretty printer for type reference. +elmTypeRefDoc :: TypeRef -> Doc ann +elmTypeRefDoc = \case + RefPrim elmPrim -> elmPrimDoc elmPrim + RefCustom (TypeName typeName) -> pretty typeName + +{- | Pretty printer for primitive Elm types. This pretty printer is used only to +display types of fields. +-} +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 + +{- | Pretty-printer for types. Adds parens for both sides when needed (when type +contains of multiple words). +-} +elmTypeParenDoc :: TypeRef -> Doc ann +elmTypeParenDoc = wrapParens . elmTypeRefDoc + +{- | Pretty printer for Elm aliases: + +@ +type alias User = + { userHeh : String + , userMeh : Int + } +@ +-} +elmAliasDoc :: ElmAlias -> Doc ann +elmAliasDoc ElmAlias{..} = nest 4 $ + vsep $ ("type alias" <+> pretty elmAliasName <+> equals) + : fieldsDoc elmAliasFields + where + fieldsDoc :: NonEmpty ElmRecordField -> [Doc ann] + fieldsDoc (fstR :| rest) = + lbrace <+> recordFieldDoc fstR + : map ((comma <+>) . recordFieldDoc) rest + ++ [rbrace] + + recordFieldDoc :: ElmRecordField -> Doc ann + recordFieldDoc ElmRecordField{..} = + pretty elmRecordFieldName + <+> colon + <+> elmTypeRefDoc elmRecordFieldType + +{- | Pretty printer for Elm types with one or more constructors: + +@ +type Status a + = Foo String Int + | Bar a + | Baz +@ + +If the type is a newtype then additionally @unTYPENAME@ function is generated: + +@ +type Id a + = Id String + +unId : Id a -> String +unId (Id x) = x +@ + +If the type is Enum this function will add enum specific functions: + +@ +type Status + = Approved + | Yoyoyo + | Wow + +showStatus : Status -> String +showStatus x = case x of + Approved -> \"Approved\" + Yoyoyo -> \"Yoyoyo\" + Wow -> \"Wow\" + +readStatus : String -> Maybe Status +readStatus x = case x of + \"Approved\" -> Just Approved + \"Yoyoyo\" -> Just Yoyoyo + \"Wow\" -> Just Wow + _ -> Nothing + +universeStatus : List Status +universeStatus = [Approved, Yoyoyo, Wow] +@ +-} +elmTypeDoc :: ElmType -> Doc ann +elmTypeDoc t@ElmType{..} = + nest 4 ( vsep $ ("type" <+> pretty elmTypeName <> sepVars) + : constructorsDoc elmTypeConstructors + ) + <> unFunc + <> enumFuncs + where + sepVars :: Doc ann + sepVars = case elmTypeVars of + [] -> emptyDoc + vars -> space <> sep (map pretty vars) + + constructorsDoc :: NonEmpty ElmConstructor -> [Doc ann] + constructorsDoc (fstC :| rest) = + equals <+> constructorDoc fstC + : map ((pipe <+>) . constructorDoc) rest + + constructorDoc :: ElmConstructor -> Doc ann + constructorDoc ElmConstructor{..} = sep $ + pretty elmConstructorName : map elmTypeRefDoc elmConstructorFields + + -- Generates 'unTYPENAME' function for newtype + unFunc :: Doc ann + unFunc = + if elmTypeIsNewtype + then line <> elmUnFuncDoc t + else emptyDoc + + enumFuncs :: Doc ann + enumFuncs = + if isEnum t + then vsep $ map (line <>) [elmEnumShowDoc t, elmEnumReadDoc t, elmEnumUniverse t] + else emptyDoc + +elmUnFuncDoc :: ElmType -> Doc ann +elmUnFuncDoc ElmType{..} = line <> vsep + [ unName <+> colon <+> typeWithVarsDoc elmTypeName elmTypeVars <+> arrow <+> result + , unName <+> parens (ctorName <+> "x") <+> equals <+> "x" + ] + where + unName :: Doc ann + unName = "un" <> pretty elmTypeName + + ctor :: ElmConstructor + ctor = NE.head elmTypeConstructors + + result :: Doc ann + result = case elmConstructorFields ctor of + [] -> "ERROR" + fld : _ -> elmTypeRefDoc fld + + ctorName :: Doc ann + ctorName = pretty $ elmConstructorName ctor + +elmEnumShowDoc :: forall ann . ElmType -> Doc ann +elmEnumShowDoc t@ElmType{..} = + line + -- function type + <> (showName <+> colon <+> pretty elmTypeName <+> arrow <+> "String") + <> line + -- function body + <> nest 4 + ( vsep $ (showName <+> "x" <+> equals <+> "case x of") + -- pattern matching + : map patternMatch (getConstructorNames t) + ) + where + showName :: Doc ann + showName = "show" <> pretty elmTypeName + + patternMatch :: Text -> Doc ann + patternMatch (pretty -> c) = c <+> arrow <+> dquotes c + +elmEnumReadDoc :: ElmType -> Doc ann +elmEnumReadDoc t@ElmType{..} = + -- function type + (readName <+> colon <+> "String" <+> arrow <+> "Maybe" <+> pretty elmTypeName) + <> line + -- function body + <> nest 4 + ( vsep $ (readName <+> "x" <+> equals <+> "case x of") + -- pattern matching + : map patternMatch (getConstructorNames t) + ++ ["_" <+> arrow <+> "Nothing"] + ) + where + readName :: Doc ann + readName = "read" <> pretty elmTypeName + + patternMatch :: Text -> Doc ann + patternMatch (pretty -> c) = dquotes c <+> arrow <+> "Just" <+> c + +elmEnumUniverse :: ElmType -> Doc ann +elmEnumUniverse t@ElmType{..} = vsep + -- function type + [ universeName <+> colon <+> "List" <+> pretty elmTypeName + , universeName <+> equals <+> align (prettyList $ getConstructorNames t) + ] + where + universeName :: Doc ann + universeName = "universe" <> pretty elmTypeName diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,9 @@ module Main (main) where +import Test.Hspec (hspec) + +import Test.Golden (goldenSpec) + + main :: IO () -main = putStrLn ("Test suite not yet implemented" :: String) +main = hspec goldenSpec diff --git a/test/Test/Golden.hs b/test/Test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Test/Golden.hs @@ -0,0 +1,20 @@ +module Test.Golden + ( goldenSpec + ) where + +import Test.Hspec (Spec, describe, it, runIO) + +import Types (OneType, defaultOneType) + +import Data.Aeson as A +import 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 == Right defaultOneType + it "default -> JSON -> Haskell == default" $ + (A.eitherDecode @OneType $ A.encode defaultOneType) == Right defaultOneType diff --git a/types/Types.hs b/types/Types.hs --- a/types/Types.hs +++ b/types/Types.hs @@ -39,11 +39,12 @@ , primsChar :: !Char , primsInt :: !Int , primsFloat :: !Double - , primsString :: !String + , primsText :: !Text , primsTime :: !UTCTime , primsMaybe :: !(Maybe Word) - , primsResult :: !(Either Int String) + , primsResult :: !(Either Int Text) , primsPair :: !(Char, Bool) + , primsTriple :: !(Char, Bool, Int) , primsList :: ![Int] } deriving (Generic, Eq, Show) #if ( __GLASGOW_HASKELL__ >= 806 ) @@ -104,9 +105,29 @@ instance ToJSON UserRequest where toJSON = elmStreetToJson instance FromJSON UserRequest where parseJSON = elmStreetParseJson +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 + +-- | For name clashes testing. +data MyResult + = Ok + | Err Text + deriving (Generic, Eq, Show) + deriving anyclass (Elm, FromJSON, ToJSON) + -- | All test types together in one type to play with. data OneType = OneType { oneTypePrims :: !Prims + , oneTypeMyUnit :: !MyUnit + , oneTypeMyResult :: !MyResult , oneTypeId :: !(Id OneType) , oneTypeAge :: !Age , oneTypeRequestStatus :: !RequestStatus @@ -122,6 +143,8 @@ -- | Type level list of all test types. type Types = '[ Prims + , MyUnit + , MyResult , Id () , Age , RequestStatus @@ -135,6 +158,8 @@ defaultOneType :: OneType defaultOneType = OneType { oneTypePrims = defaultPrims + , oneTypeMyUnit = MyUnit () + , oneTypeMyResult = Err "clashing test" , oneTypeId = Id "myId" , oneTypeAge = Age 18 , oneTypeRequestStatus = Reviewing @@ -150,11 +175,12 @@ , primsChar = 'a' , primsInt = 42 , primsFloat = 36.6 - , primsString = "heh" + , 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] }