diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +`elm-street` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +0.0.0 +===== + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/Holmusk/elm-street/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,338 @@ +# elm-street + +[![Hackage](https://img.shields.io/hackage/v/elm-street.svg)](https://hackage.haskell.org/package/elm-street) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](LICENSE) +[![Stackage Lts](http://stackage.org/package/elm-street/badge/lts)](http://stackage.org/lts/package/elm-street) +[![Stackage Nightly](http://stackage.org/package/elm-street/badge/nightly)](http://stackage.org/nightly/package/elm-street) + +Crossing the road between Haskell and Elm. + +## What this library about? + +`Elm-street` allows you to generate automatically derived from Haskell types +definitions of Elm data types, JSON encoders and decoders. This helps to avoid +writing and maintaining huge chunk of boilerplate code when developing full-stack +applications. + +## Getting started + +In order to use `elm-street` features, you need to perform the following steps: + +1. Add `elm-street` to the dependencies of your Haskell package. +2. Derive the `Elm` typeclass for relevant data types. You also need to derive + JSON instances according to `elm-street` naming scheme. + This can be done like this: + ```haskell + import Elm (Elm, elmStreetParseJson, elmStreetToJson) + + data User = User + { userName :: Text + , userAge :: Int + } deriving (Generic) + deriving anyclass (Elm) + + instance ToJSON User where toJSON = elmStreetToJson + instance FromJSON User where parseJSON = elmStreetParseJson + ``` + > **NOTE:** This requires extensions `-XDerivingStrategies`, `-XDeriveGeneric`, `-XDeriveAnyClass`. + + Alternatively you can use `-XDerivingVia` to remove some boilerplate (available since GHC 8.6.1): + ```haskell + import Elm (Elm, ElmStreet (..)) + + data User = User + { userName :: Text + , userAge :: Int + } deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet User + ``` +3. Create list of all types you want to expose to Elm: + ```haskell + type Types = + '[ User + , Status + ] + ``` + > **NOTE:** This requires extension `-XDataKinds`. +4. Use `generateElm` function to output definitions to specified directory under + specified module prefix. + ``` + main :: IO () + main = generateElm @Types $ defaultSettings "frontend/src" ["Core", "Generated"] + ``` + > **NOTE:** This requires extension `-XTypeApplications`. + + The above command when called generates the following files: + + + `frontend/src/Core/Generated/Types.elm`: `Core.Generated.Types` module with the definitions of all types + + `frontend/src/Core/Generated/Encoder.elm`: `Core.Generated.Encoder` module with the JSON encoders for the types + + `frontend/src/Core/Generated/Decoder.elm`: `Core.Generated.Decoder` module with the JSON decoders for the types + + `frontend/src/Core/Generated/ElmStreet.elm`: `Core.Generated.ElmStreet` module with bundled helper functions + +## Elm-side preparations + +If you want to use capabilities provided by `elm-street` in your Elm +application, you need to have several Elm packages preinstalled in the project. You +can install them with the following commands: + +```shell +elm install elm/time +elm install elm/json +elm install NoRedInk/elm-json-decode-pipeline +elm install rtfeldman/elm-iso8601-date-strings +``` + +## Library restrictions + +`Elm-street` is **not** trying to be as general as possible and support every +use-case. The library is opinionated in some decisions and contains several +limitations, specifically: + +1. Record fields must be prefixed with the type name or its abbreviation. + ```haskell + data UserStatus = UserStatus + { userStatusId :: Id + , userStatusRemarks :: Text + } + + data HealthReading = HealthReading + { hrUser :: User + , hrDate :: UTCTime + , hrWeight :: Double + } + ``` +2. Data types with type variables are not supported (see [issue #45](https://github.com/Holmusk/elm-street/issues/45) for more details). + Though, if type variables are phantom, you still can implement `Elm` instance which + will generate valid Elm defintions. Here is how you can create `Elm` instance for + `newtype`s with phantom type variables: + ```haskell + newtype Id a = Id { unId :: Text } + + instance Elm (Id a) where + toElmDefinition _ = elmNewtype @Text "Id" "unId" + ``` +3. Sum types with records are not supported (because it's a bad practice to have + records in sum types). + ```haskell + -- - Not supported + data Address + = Post { postCode :: Text } + | Full { fullStreet :: Text, fullHouse :: Int } + + ``` +4. Sum types with more than 8 fields in at least one constructor are not + supported. + ```haskell + -- - Not supported + data Foo + = Bar Int Text + | Baz Int Int Text Text Double Double Bool Bool Char + ``` +5. Records with fields that reference the type itself are not supported. This + limitation is due to the fact that `elm-street` generates `type alias` for + record data type. So the generated Elm type for the following Haskell data + type won't compile in Elm: + ```haskell + data User = User + { userName :: Text + , userFollowers :: [User] + } + ``` +6. Generated JSON encoders and decoders are consistent with default behavior of + derived `ToJSON/FromJSON` instances from the `aeson` library except you need + to strip record field prefixes. Fortunately, this also can be done + generically. You can use functions from `Elm.Aeson` module to derive `JSON` + instances from the `aeson` package. +7. Only `UTCTime` Haskell data type is supported and it's translated to `Posix` + type in Elm. + +## Play with frontend example + +The `frontend` directory contains example of minimal Elm project that shows how +generated types are used. To play with this project, do: + +1. Build and execute the `generate-elm` binary: + ``` + cabal new-run generate-elm + ``` +2. Run Haskell backend: + ``` + cabal new-run run-backend + ``` +3. In separate terminal tab go to the `frontend` folder: + ``` + cd frontend + ``` +4. Run the frontend: + ``` + elm-app start + ``` + +## Generated examples + +Below you can see some examples of how Haskell data types are converted to Elm +types with JSON encoders and decoders using the `elm-street` library. + +### Records + +**Haskell** + +```haskell +data User = User + { userName :: Text + , userAge :: Int + } deriving (Generic) + deriving anyclass (Elm) +``` + +**Elm** + +```elm +type alias User = + { name : String + , age : Int + } + +encodeUser : User -> Value +encodeUser x = E.object + [ ("name", E.string x.name) + , ("age", E.int x.age) + ] + +decodeUser : Decoder User +decodeUser = D.succeed User + |> required "name" D.string + |> required "age" D.int +``` + +### Enums + +**Haskell** + +```haskell +data RequestStatus + = Approved + | Rejected + | Reviewing + deriving (Generic) + deriving anyclass (Elm) +``` + +**Elm** + +```elm +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] + +encodeRequestStatus : RequestStatus -> Value +encodeRequestStatus = E.string << showRequestStatus + +decodeRequestStatus : Decoder RequestStatus +decodeRequestStatus = elmStreetDecodeEnum readRequestStatus +``` + +### Newtypes + +**Haskell** + +```haskell +newtype Age = Age + { unAge :: Int + } deriving (Generic) + deriving anyclass (Elm) +``` + +**Elm** + +```elm +type alias Age = + { age : Int + } + +encodeAge : Age -> Value +encodeAge x = E.int x.age + +decodeAge : Decoder Age +decodeAge = D.map Age D.int +``` + +### Newtypes with phantom types + +**Haskell** + +```haskell +newtype Id a = Id { unId :: Text } + +instance Elm (Id a) where + toElmDefinition _ = elmNewtype @Text "Id" "unId" +``` + +**Elm** + +```elm +type alias Id = + { unId : String + } + +encodeId : Id -> Value +encodeId x = E.string x.unId + +decodeId : Decoder Id +decodeId = D.map Id D.string +``` + +### Sum types + +**Haskell** + +```haskell +data Guest + = Regular Text Int + | Visitor Text + | Blocked + deriving (Generic) + deriving anyclass (Elm) +``` + +**Elm** + +```elm +type Guest + = Regular String Int + | Visitor String + | Blocked + +encodeGuest : Guest -> Value +encodeGuest x = E.object <| case x of + Regular x1 x2 -> [("tag", E.string "Regular"), ("contents", E.list identity [E.string x1, E.int x2])] + Visitor x1 -> [("tag", E.string "Visitor"), ("contents", E.list identity [E.string x1])] + Blocked -> [("tag", E.string "Blocked"), ("contents", E.list identity [])] + +decodeGuest : Decoder Guest +decodeGuest = + let decide : String -> Decoder Guest + decide x = case x of + "Regular" -> D.field "contents" <| D.map2 Regular (D.index 0 D.string) (D.index 1 D.int) + "Visitor" -> D.field "contents" <| D.map Visitor (D.index 0 D.string) + "Blocked" -> D.succeed Blocked + c -> D.fail <| "Guest doesn't have such constructor: " ++ c + in D.andThen decide (D.field "tag" D.string) +``` diff --git a/backend/Api.hs b/backend/Api.hs new file mode 100644 --- /dev/null +++ b/backend/Api.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} + +module Api + ( app + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Proxy (Proxy (..)) +import Network.Wai (Application) +import Servant.API ((:<|>) (..), (:>), Get, JSON, Post, ReqBody) +import Servant.Server (Handler, Server, serve) + +import Types (OneType, defaultOneType) + + +type TypesApi + -- | Get 'OneType' from the backend side + = "get" :> Get '[JSON] OneType + -- | Receive 'OneType' from the frontend side + :<|> "post" :> ReqBody '[JSON] OneType :> Post '[JSON] Bool + +typesApi :: Proxy TypesApi +typesApi = Proxy + +typesServer :: Server TypesApi +typesServer = getHandler :<|> postHandler + +getHandler :: Handler OneType +getHandler = liftIO $ putStrLn "Get handler" >> pure defaultOneType + +postHandler :: OneType -> Handler Bool +postHandler = liftIO . (putStrLn "Post handler" >>) . pure . (defaultOneType ==) + +app :: Application +app = serve typesApi typesServer diff --git a/backend/Main.hs b/backend/Main.hs new file mode 100644 --- /dev/null +++ b/backend/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Network.Wai.Handler.Warp (run) + +import Api (app) + + +main :: IO () +main = run 8080 app diff --git a/elm-street.cabal b/elm-street.cabal new file mode 100644 --- /dev/null +++ b/elm-street.cabal @@ -0,0 +1,199 @@ +cabal-version: 2.0 +name: elm-street +version: 0.0.0 +synopsis: Crossing the road between Haskell and Elm +description: + `Elm-street` allows you to generate automatically derived from Haskell types + definitions of Elm data types, JSON encoders and decoders. This helps to avoid + writing and maintaining huge chunk of boilerplate code when developing full-stack + applications. +homepage: https://github.com/Holmusk/elm-street +bug-reports: https://github.com/Holmusk/elm-street/issues +license: MPL-2.0 +license-file: LICENSE +author: Holmusk +maintainer: tech@holmusk.com +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 + +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 + + build-depends: base >= 4.11.1.0 && < 4.13 + , aeson >= 1.4 + , directory ^>= 1.3 + , filepath ^>= 1.4 + , prettyprinter ^>= 1.2.1 + , text ^>= 1.2 + , 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 + +library types + hs-source-dirs: types + exposed-modules: Types + + build-depends: base >= 4.11 && < 4.13 + , 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 + hs-source-dirs: generate-elm + main-is: Main.hs + + build-depends: base + , elm-street + , types + + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + + default-language: Haskell2010 + +executable run-backend + hs-source-dirs: backend + main-is: Main.hs + other-modules: Api + + build-depends: base + , servant ^>= 0.15 + , servant-server ^>= 0.15 + , types + , wai ^>= 3.2.2 + , warp ^>= 3.2 + + ghc-options: -Wall + -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 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + + build-depends: base >= 4.11.1.0 && < 4.13 + , elm-street + + + ghc-options: -Wall + -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 new file mode 100644 --- /dev/null +++ b/generate-elm/Main.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeApplications #-} + +{- | Generates Elm types from Haskell @types@ internal library. + +The generated files can be found in the @elm-example/src@ folder. +-} + +module Main (main) where + +import Elm (defaultSettings, generateElm) +import Types (Types) + + +main :: IO () +main = generateElm @Types $ defaultSettings "frontend/src" ["Core"] diff --git a/src/Elm.hs b/src/Elm.hs new file mode 100644 --- /dev/null +++ b/src/Elm.hs @@ -0,0 +1,16 @@ +{- | Library for generic conversion of data types from Haskell to Elm. +-} + +module Elm + ( module Elm.Aeson + , module Elm.Ast + , module Elm.Generate + , module Elm.Generic + , module Elm.Print + ) where + +import Elm.Aeson +import Elm.Ast +import Elm.Generate +import Elm.Generic +import Elm.Print diff --git a/src/Elm/Aeson.hs b/src/Elm/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Aeson.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Options used to derive FromJSON/ToJSON instance. These options generally +comply to @elm-street@ rules regarding names. +-} + +module Elm.Aeson + ( elmStreetParseJson + , elmStreetToJson + , elmStreetJsonOptions + + , ElmStreet (..) + ) where + +import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, Options (..), ToJSON (..), Value, Zero, + defaultOptions, genericParseJSON, genericToJSON) +import Data.Aeson.Types (Parser) +import GHC.Generics (Generic, Rep) +import Type.Reflection (Typeable, typeRep) + +import Elm.Ast (TypeName (..)) +import Elm.Generic (Elm (..), GenericElmDefinition (..), HasLessThanEightUnnamedFields, + HasNoNamedSum, HasNoTypeVars, stripTypeNamePrefix) + +import qualified Data.Text as T +import qualified GHC.Generics as Generic (from) + + +{- | Allows to create 'Data.Aeson.FromJSON' instance that strips the supported +by @elm-street@ data type name prefix from every field.. + +__Example:__ + +With the following @JSON@ + +@ +{ \"name\": \"John\" +, \"age\": 42 +} +@ + +it is decoded it the following way for each of the specified types: + ++-------------------------------+--------------------------+ +| Haskell data type | Parsed type | ++===============================+==========================+ +| @ | @ | +| data User = User | User | +| \ { userName :: String | { userName = \"John\" | +| \ , userAge :: Int | , userAge = 42 | +| \ } | } | +| @ | @ | ++-------------------------------+--------------------------+ +| | | +| @ | @ | +| data LongUser = LongUser | LongUser | +| { luName :: String | { luName = \"John\" | +| , luAge :: Int | , luAge = 42 | +| } | } | +| @ | @ | ++-------------------------------+--------------------------+ +| @ | @ | +| data SimpleUser = SimpleUser | SimpleUser | +| { name :: String | { name = \"John\" | +| , age :: Int | , age = 42 | +| } | } | +| @ | @ | ++-------------------------------+--------------------------+ + +>>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show) +>>> instance FromJSON User where parseJSON = elmStreetParseJson +>>> decode @User "{ \"name\": \"John\", \"age\": 42 }" +Just (User {userName = "John", userAge = 42}) + + +>>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show) +>>> instance FromJSON VeryLongType where parseJSON = elmStreetParseJson +>>> decode @VeryLongType "{ \"name\": \"John\", \"age\": 42 }" +Just (VeryLongType {vltName = "John", vltAge = 42}) + +-} +elmStreetParseJson + :: forall a . + (Typeable a, Generic a, GFromJSON Zero (Rep a)) + => Value + -> Parser a +elmStreetParseJson = genericParseJSON (elmStreetJsonOptions @a) + +{- | Allows to create 'Data.Aeson.ToJSON' instance that strips the supported by +@elm-street@ data type name prefix from every field. + +>>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show) +>>> instance ToJSON User where toJSON = elmStreetToJson +>>> encode $ User { userName = "John", userAge = 42 } +"{\"age\":42,\"name\":\"John\"}" + +>>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show) +>>> instance ToJSON VeryLongType where toJSON = elmStreetToJson +>>> encode $ VeryLongType {vltName = "John", vltAge = 42} +"{\"age\":42,\"name\":\"John\"}" + +>>> data User = User { name :: String, age :: Int } deriving (Generic, Show) +>>> instance ToJSON User where toJSON = elmStreetToJson +>>> encode $ User { name = "John", age = 42 } +"{\"age\":42,\"name\":\"John\"}" +-} +elmStreetToJson + :: forall a . + (Typeable a, Generic a, GToJSON Zero (Rep a)) + => a + -> Value +elmStreetToJson = genericToJSON (elmStreetJsonOptions @a) + +{- | Options to strip type name from the field names. + ++----------------+----------------+---------------------+ +| Data type name | Field name | Stripped field name | ++================+================+=====================+ +| @User@ | @userName@ | @name@ | ++----------------+----------------+---------------------+ +| @AaaBbbCcc@ | @abcFieldName@ | @fieldName@ | ++----------------+----------------+---------------------+ +| @Foo@ | @field@ | @field@ | ++----------------+----------------+---------------------+ +| @Field@ | @field@ | @field@ | ++----------------+----------------+---------------------+ + +-} +elmStreetJsonOptions :: forall a . Typeable a => Options +elmStreetJsonOptions = defaultOptions + { fieldLabelModifier = T.unpack . stripTypeNamePrefix typeName . T.pack + } + where + typeName :: TypeName + typeName = TypeName $ T.pack $ show $ typeRep @a + + +{- | Newtype for reusing in @DerivingVia@. + +In order to use it with your type @MyType@ add the following deriving to your type: + +@ + __deriving__ (Elm, ToJSON, FromJSON) __via__ ElmStreet MyType +@ +-} +newtype ElmStreet a = ElmStreet + { unElmStreet :: a + } + +instance ( HasNoTypeVars a + , HasLessThanEightUnnamedFields a + , HasNoNamedSum a + , Generic a + , GenericElmDefinition (Rep a) + ) => Elm (ElmStreet a) where + toElmDefinition _ = genericToElmDefinition + $ Generic.from (error "Proxy for generic elm was evaluated" :: a) + +instance (Typeable a, Generic a, GToJSON Zero (Rep a)) => ToJSON (ElmStreet a) where + toJSON = elmStreetToJson . unElmStreet + +instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (ElmStreet a) where + parseJSON = fmap ElmStreet . elmStreetParseJson diff --git a/src/Elm/Ast.hs b/src/Elm/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Ast.hs @@ -0,0 +1,100 @@ +{- | AST representing structure of Elm types. Haskell generic representation is +converted to this AST which later is going to be pretty-printed. +-} + +module Elm.Ast + ( ElmDefinition (..) + + , ElmAlias (..) + , ElmType (..) + , ElmPrim (..) + + , ElmRecordField (..) + , ElmConstructor (..) + , isEnum + , getConstructorNames + + , TypeName (..) + , TypeRef (..) + , definitionToRef + ) where + +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Text (Text) + + +-- | Elm data type definition. +data ElmDefinition + = DefAlias !ElmAlias + | 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@ + } deriving (Show) + +-- | Single file of @type alias@. +data ElmRecordField = ElmRecordField + { elmRecordFieldType :: !TypeRef + , elmRecordFieldName :: !Text + } deriving (Show) + +-- | Wrapper for name of the type. +newtype TypeName = TypeName + { unTypeName :: Text + } deriving (Show) + +-- | AST for @type@ in Elm. +data ElmType = ElmType + { elmTypeName :: !Text -- ^ Name of the data type + , elmTypeVars :: ![Text] -- ^ List of type variables; currently only phantom variables + , elmTypeIsNewtype :: !Bool -- ^ 'True' if Haskell type is a @newtype@ + , elmTypeConstructors :: !(NonEmpty ElmConstructor) -- ^ List of constructors + } deriving (Show) + +-- | Constructor of @type@. +data ElmConstructor = ElmConstructor + { elmConstructorName :: !Text -- ^ Name of the constructor + , elmConstructorFields :: ![TypeRef] -- ^ Fields of the constructor + } deriving (Show) + +-- | Checks if the given 'ElmType' is Enum. +isEnum :: ElmType -> Bool +isEnum ElmType{..} = null elmTypeVars && null (foldMap elmConstructorFields elmTypeConstructors) + +-- | Gets the list of the constructor names. +getConstructorNames :: ElmType -> [Text] +getConstructorNames ElmType{..} = map elmConstructorName $ toList elmTypeConstructors + +-- | 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 + deriving (Show) + +-- | Reference to another existing type. +data TypeRef + = RefPrim !ElmPrim + | RefCustom !TypeName + deriving (Show) + +-- | Extracts reference to the existing data type type from some other type elm defintion. +definitionToRef :: ElmDefinition -> TypeRef +definitionToRef = \case + DefAlias ElmAlias{..} -> RefCustom $ TypeName elmAliasName + DefType ElmType{..} -> RefCustom $ TypeName elmTypeName + DefPrim elmPrim -> RefPrim elmPrim diff --git a/src/Elm/Generate.hs b/src/Elm/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Generate.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +module Elm.Generate + ( Settings (..) + , defaultSettings + , generateElm + + -- * Internal helpers + , RenderElm (..) + ) where + +import Data.Kind (Type) +import Data.List (intercalate) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import System.Directory (createDirectoryIfMissing) +import System.FilePath ((<.>), ()) + +import Elm.Generic (Elm (..)) +import Elm.Print (decodeChar, decodeEither, decodeEnum, decodePair, encodeEither, encodeMaybe, + encodePair, prettyShowDecoder, prettyShowDefinition, prettyShowEncoder) + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + + +-- | Settings for outputting generated Elm code. +data Settings = Settings + { settingsDirectory :: !FilePath -- ^ Directory to put generated files, e.g. @frontend\/src@ + , settingsModule :: ![FilePath] -- ^ List of module parts, like @["ABC", "Core"]@ + , settingsTypesFile :: !FilePath -- ^ File name for module with types, e.g. @Types@ + , settingsEncoderFile :: !FilePath -- ^ File name for module with JSON encoders, e.g. @Encoder@ + , settingsDecoderFile :: !FilePath -- ^ File name for module with JSON decoders, e.g. @Decoder@ + } + +{- | Default settings for generating Elm definitions. You only need to pass name +of the directory and module path prefix. Other settings parameters set to: + +1. 'settingsTypesFile': @Types@ +2. 'settingsEncoderFile': @Encoder@ +3. 'settingsDecoderFile': @Decoder@ +-} +defaultSettings :: FilePath -> [FilePath] -> Settings +defaultSettings settingsDirectory settingsModule = Settings + { settingsTypesFile = "Types" + , settingsEncoderFile = "Encoder" + , settingsDecoderFile = "Decoder" + , .. + } + +-- | Typeclass for generating elm definitions for the list of types. +class RenderElm (types :: [Type]) where + renderType :: [Text] + renderEncoder :: [Text] + renderDecoder :: [Text] + +instance RenderElm '[] where + renderType = [] + renderEncoder = [] + renderDecoder = [] + +instance (Elm t, RenderElm ts) => RenderElm (t ': ts) where + renderType = "" : toElmTypeSource @t : renderType @ts + renderEncoder = "" : toElmEncoderSource @t : renderEncoder @ts + renderDecoder = "" : toElmDecoderSource @t : renderDecoder @ts + +toElmTypeSource :: forall a . Elm a => Text +toElmTypeSource = prettyShowDefinition $ toElmDefinition $ Proxy @a + +toElmEncoderSource :: forall a . Elm a => Text +toElmEncoderSource = prettyShowEncoder $ toElmDefinition $ Proxy @a + +toElmDecoderSource :: forall a . Elm a => Text +toElmDecoderSource = prettyShowDecoder $ toElmDefinition $ Proxy @a + +{- | Generate elm definitions for the list of types. This function is supposed +to be called like this: + +@ +__type__ Types = + '[ User + , UserStatus + , Measure + ] + +main :: IO () +main = generateElm @Types $ defaultSettings "frontend\/src\/" ["ABC", "Core"] +@ +-} +generateElm :: forall (ts :: [Type]) . RenderElm ts => Settings -> IO () +generateElm Settings{..} = do + createDirectoryIfMissing True fullPath + + writeElm settingsTypesFile $ typesHeader : renderType @ts + writeElm settingsEncoderFile $ encoderHeader : renderEncoder @ts + writeElm settingsDecoderFile $ decoderHeader : renderDecoder @ts + + writeElm "ElmStreet" elmStreetDefinitions + where + moduleDir, fullPath :: FilePath + moduleDir = foldr () "" settingsModule + fullPath = settingsDirectory moduleDir + + writeElm :: FilePath -> [Text] -> IO () + writeElm file defs = TIO.writeFile (fullPath file <.> "elm") (T.unlines defs) + + joinModule :: [String] -> Text + joinModule = T.pack . intercalate "." + + typesModule, encoderModule, decoderModule :: Text + typesModule = joinModule $ settingsModule ++ [settingsTypesFile] + encoderModule = joinModule $ settingsModule ++ [settingsEncoderFile] + decoderModule = joinModule $ settingsModule ++ [settingsDecoderFile] + streetModule = joinModule $ settingsModule ++ ["ElmStreet"] + + typesHeader :: Text + typesHeader = T.unlines + [ "module " <> typesModule <> " exposing (..)" + , "" + , "import Time exposing (Posix)" + ] + + encoderHeader :: Text + encoderHeader = T.unlines + [ "module " <> encoderModule <> " exposing (..)" + , "" + , "import Iso8601 as Iso" + , "import Json.Encode as E exposing (..)" + , "" + , "import " <> streetModule <> " exposing (..)" + , "import " <> typesModule <> " exposing (..)" + ] + + decoderHeader :: Text + decoderHeader = T.unlines + [ "module " <> decoderModule <> " exposing (..)" + , "" + , "import Iso8601 as Iso" + , "import Json.Decode as D exposing (..)" + , "import Json.Decode.Pipeline as D exposing (required)" + , "" + , "import " <> streetModule <> " exposing (..)" + , "import " <> typesModule <> " exposing (..)" + ] + + elmStreetDefinitions :: [Text] + elmStreetDefinitions = + [ "module " <> streetModule <> " exposing (..)" + , "" + , "import Json.Encode as E exposing (Value)" + , "import Json.Decode as D exposing (Decoder)" + , "import Json.Decode.Pipeline as D exposing (..)" + , "" + , "" + , encodeMaybe + , encodeEither + , encodePair + + , decodeEnum + , decodeChar + , decodeEither + , decodePair + ] diff --git a/src/Elm/Generic.hs b/src/Elm/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Generic.hs @@ -0,0 +1,378 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generic conversion of Haskell data types to Elm types. +-} + +module Elm.Generic + ( -- * Main data type for the user + Elm (..) + , elmRef + + -- * Smart constructors + , elmNewtype + + -- * Generic utilities + , GenericElmDefinition (..) + , GenericElmConstructors (..) + , GenericElmFields (..) + + , GenericConstructor (..) + , toElmConstructor + + -- * Type families for compile-time checks + , HasNoTypeVars + , TypeVarsError + + , HasLessThanEightUnnamedFields + , FieldsError + , CheckFields + , Max + + , HasNoNamedSum + , NamedSumError + , CheckNamedSum + , CheckConst + + -- * Internals + , stripTypeNamePrefix + ) where + +import Data.Char (isLower, toLower) +import Data.Int (Int16, Int32, Int8) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +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.TypeLits (ErrorMessage (..), Nat, TypeError) +import GHC.TypeNats (type (<=?), type (+)) + +import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..), + ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), definitionToRef) + +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT (Text) +import qualified GHC.Generics as Generic (from) + + +{- | Typeclass that describes how Haskell data types are converted to Elm ones. +-} +class Elm a where + toElmDefinition :: Proxy a -> ElmDefinition + + default toElmDefinition + :: ( HasNoTypeVars a + , HasLessThanEightUnnamedFields a + , HasNoNamedSum a + , Generic a + , GenericElmDefinition (Rep a) + ) + => Proxy a + -> ElmDefinition + toElmDefinition _ = genericToElmDefinition + $ Generic.from (error "Proxy for generic elm was evaluated" :: a) + +{- | Returns 'TypeRef' for the existing type. This function always returns the +name of the type without any type variables added. +-} +elmRef :: forall a . Elm a => TypeRef +elmRef = definitionToRef $ toElmDefinition $ Proxy @a + +---------------------------------------------------------------------------- +-- Primitive instances +---------------------------------------------------------------------------- + +instance Elm () where toElmDefinition _ = DefPrim ElmUnit +instance Elm Void where toElmDefinition _ = DefPrim ElmNever +instance Elm Bool where toElmDefinition _ = DefPrim ElmBool +instance Elm Char where toElmDefinition _ = DefPrim ElmChar + +instance Elm Int where toElmDefinition _ = DefPrim ElmInt +instance Elm Int8 where toElmDefinition _ = DefPrim ElmInt +instance Elm Int16 where toElmDefinition _ = DefPrim ElmInt +instance Elm Int32 where toElmDefinition _ = DefPrim ElmInt +instance Elm Word where toElmDefinition _ = DefPrim ElmInt +instance Elm Word8 where toElmDefinition _ = DefPrim ElmInt +instance Elm Word16 where toElmDefinition _ = DefPrim ElmInt +instance Elm Word32 where toElmDefinition _ = DefPrim ElmInt + +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 + +-- 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 +-- instance Elm LB.ByteString where toElmDefinition _ = DefPrim ElmString + +instance Elm UTCTime where toElmDefinition _ = DefPrim ElmTime + +instance Elm a => Elm (Maybe a) where + toElmDefinition _ = DefPrim $ ElmMaybe $ elmRef @a + +instance (Elm a, Elm b) => Elm (Either a b) where + toElmDefinition _ = DefPrim $ ElmResult (elmRef @a) (elmRef @b) + +instance (Elm a, Elm b) => Elm (a, b) where + toElmDefinition _ = DefPrim $ ElmPair (elmRef @a) (elmRef @b) + +instance Elm a => Elm [a] where + toElmDefinition _ = DefPrim $ ElmList (elmRef @a) + +instance Elm a => Elm (NonEmpty a) where + toElmDefinition _ = DefPrim $ ElmList (elmRef @a) + +---------------------------------------------------------------------------- +-- Smart constructors +---------------------------------------------------------------------------- + +{- | This function can be used to create manual 'Elm' instances easily for +@newtypes@ where 'Generic' deriving doesn't work. This function can be used like +this: + +@ +__newtype__ Id a = Id { unId :: Text } + +__instance__ Elm (Id a) __where__ + toElmDefinition _ = elmNewtype @Text "Id" "unId" +@ +-} +elmNewtype :: forall a . Elm a => Text -> Text -> ElmDefinition +elmNewtype typeName fieldName = DefAlias $ ElmAlias + { elmAliasName = typeName + , elmAliasFields = ElmRecordField (elmRef @a) fieldName :| [] + , elmAliasIsNewtype = True + } + +---------------------------------------------------------------------------- +-- Generic instances +---------------------------------------------------------------------------- + +{- | Generic typeclass to generate whole 'ElmDefinition'. It has only one +instance: for the first top-level metadata that contains metainformation about +data type like @data type name@. Then it collects all constructors of the data +type and decides what to generate. +-} +class GenericElmDefinition (f :: k -> Type) where + genericToElmDefinition :: f a -> ElmDefinition + +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 + 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 + Nothing -> DefType $ ElmType ("ERROR_" <> typeName) [] False (ElmConstructor "ERROR" [] :| []) + Just ctors -> DefType $ ElmType typeName [] elmIsNewtype ctors + where + typeName :: Text + typeName = T.pack $ datatypeName datatype + + elmIsNewtype :: Bool + elmIsNewtype = isNewtype datatype + +rightToMaybe :: Either l r -> Maybe r +rightToMaybe = either (const Nothing) Just + +{- | Intermediate data type to help with the conversion from Haskell +constructors to Elm AST. In Haskell constructor fields may have names but may +not have. +-} +data GenericConstructor = GenericConstructor + { genericConstructorName :: !Text + , genericConstructorFields :: ![(TypeRef, Maybe Text)] + } + +{- | Generic constructor can be in one of the three states: + +1. No fields: enum constructor. +2. All fields have names: record constructor. +3. Not all fields have names: plain constructor. +-} +toElmConstructor :: GenericConstructor -> Either (NonEmpty ElmRecordField) ElmConstructor +toElmConstructor GenericConstructor{..} = case genericConstructorFields of + [] -> Right $ ElmConstructor genericConstructorName [] + f:fs -> case traverse toRecordField (f :| fs) of + Nothing -> Right $ ElmConstructor genericConstructorName $ map fst genericConstructorFields + Just fields -> Left fields + where + toRecordField :: (TypeRef, Maybe Text) -> Maybe ElmRecordField + toRecordField (typeRef, maybeFieldName) = ElmRecordField typeRef <$> maybeFieldName + + +{- | Typeclass to collect all constructors of the Haskell data type generically. -} +class GenericElmConstructors (f :: k -> Type) where + genericToElmConstructors + :: TypeName -- ^ Name of the data type; to be stripped + -> f a -- ^ Generic value + -> NonEmpty GenericConstructor -- ^ List of the data type constructors + +-- | If it's a sum type then just combine constructors +instance (GenericElmConstructors f, GenericElmConstructors g) => GenericElmConstructors (f :+: g) where + genericToElmConstructors name _ = + genericToElmConstructors name (error "'f :+:' is evaluated" :: f p) + <> genericToElmConstructors name (error "':+: g' is evaluated" :: g p) + +-- | Create singleton list for case of a one constructor. +instance (Constructor c, GenericElmFields f) => GenericElmConstructors (C1 c f) where + genericToElmConstructors name constructor = pure $ GenericConstructor + (T.pack $ conName constructor) + (genericToElmFields name $ unM1 constructor) + +-- | Collect all fields when inside constructor. +class GenericElmFields (f :: k -> Type) where + genericToElmFields + :: TypeName -- ^ Name of the data type; to be stripped + -> f a -- ^ Generic value + -> [(TypeRef, Maybe Text)] + +-- | If multiple fields then just combine all results. +instance (GenericElmFields f, GenericElmFields g) => GenericElmFields (f :*: g) where + genericToElmFields name _ = + genericToElmFields name (error "'f :*:' is evaluated" :: f p) + <> genericToElmFields name (error "':*: g' is evaluated" :: g p) + +-- | Constructor without fields. +instance GenericElmFields U1 where + genericToElmFields _ _ = [] + +-- | Single constructor field. +instance (Selector s, Elm a) => GenericElmFields (S1 s (Rec0 a)) where + genericToElmFields typeName selector = case selName selector of + "" -> [(elmRef @a, Nothing)] + name -> [(elmRef @a, Just $ stripTypeNamePrefix typeName $ T.pack name)] + +{- | Strips name of the type name from field name prefix. + +>>> stripTypeNamePrefix (TypeName "User") "userName" +"name" + +>>> stripTypeNamePrefix (TypeName "HealthReading") "healthReadingId" +"id" + +>>> stripTypeNamePrefix (TypeName "RecordUpdate") "ruRows" +"rows" + +>>> stripTypeNamePrefix (TypeName "Foo") "foo" +"foo" + +>>> stripTypeNamePrefix (TypeName "Foo") "abc" +"abc" +-} +stripTypeNamePrefix :: TypeName -> Text -> Text +stripTypeNamePrefix (TypeName typeName) fieldName = + case T.stripPrefix (headToLower typeName) fieldName of + Just rest -> leaveIfEmpty rest + Nothing -> leaveIfEmpty (T.dropWhile isLower fieldName) + where + headToLower :: Text -> Text + headToLower t = case T.uncons t of + Nothing -> error "Cannot use 'headToLower' on empty Text" + Just (x, xs) -> T.cons (toLower x) xs + + -- if all lower case then leave field as it is + leaveIfEmpty :: Text -> Text + leaveIfEmpty rest = if T.null rest then fieldName else headToLower rest + +---------------------------------------------------------------------------- +-- ~Magic~ +---------------------------------------------------------------------------- + +{- | This type family checks whether data type has type variables and throws +custom compiler error if it has. Since there's no generic way to get all type +variables, current implementation is limited only to 6 variables. This looks +like a reasonable number. +-} +type family HasNoTypeVars (f :: k) :: Constraint where + HasNoTypeVars (t a b c d e f) = TypeError (TypeVarsError t 6) + HasNoTypeVars (t a b c d e) = TypeError (TypeVarsError t 5) + HasNoTypeVars (t a b c d) = TypeError (TypeVarsError t 4) + HasNoTypeVars (t a b c) = TypeError (TypeVarsError t 3) + HasNoTypeVars (t a b) = TypeError (TypeVarsError t 2) + HasNoTypeVars (t a) = TypeError (TypeVarsError t 1) + HasNoTypeVars t = () + +type family TypeVarsError (t :: k) (n :: Nat) :: ErrorMessage where + TypeVarsError t n = + 'Text "'elm-street' currently doesn't support Generic deriving of the 'Elm' typeclass" + ':$$: 'Text "for data types with type variables. But '" + ':<>: 'ShowType t ':<>: 'Text "' has " ':<>: 'ShowType n ':<>: 'Text " variables." + ':$$: 'Text "" + ':$$: 'Text "See the following issue for more details:" + ':$$: 'Text " * https://github.com/Holmusk/elm-street/issues/45" + ':$$: 'Text "" + +{- | This type family checks whether each constructor of the sum data type has +less than eight unnamed fields and throws custom compiler error if it has. +-} +type family HasLessThanEightUnnamedFields (f :: k) :: Constraint where + HasLessThanEightUnnamedFields t = + If (CheckFields (Rep t) <=? 8) + (() :: Constraint) + (TypeError (FieldsError t)) + +type family CheckFields (f :: k -> Type) :: Nat where + CheckFields (D1 _ f) = CheckFields f + CheckFields (f :+: g) = Max (CheckFields f) (CheckFields g) + CheckFields (C1 _ f) = CheckFields f + CheckFields (f :*: g) = CheckFields f + CheckFields g + CheckFields (S1 ('MetaSel ('Just _ ) _ _ _) _) = 0 + CheckFields (S1 _ _) = 1 + CheckFields _ = 0 + +type family Max (x :: Nat) (y :: Nat) :: Nat where + Max x y = If (x <=? y) y x + +type family FieldsError (t :: k) :: ErrorMessage where + FieldsError t = + 'Text "'elm-street' doesn't support Constructors with more than 8 unnamed fields." + ':$$: 'Text "But '" ':<>: 'ShowType t ':<>: 'Text "' has more." + +{- | This type family checks whether each constructor of the sum data type has +less than eight unnamed fields and throws custom compiler error if it has. +-} +type family HasNoNamedSum (f :: k) :: Constraint where + HasNoNamedSum t = + If (CheckNamedSum (Rep t)) + (TypeError (NamedSumError t)) + (() :: Constraint) + +-- | Is the data type id Sum type with named fields? +type family CheckNamedSum (f :: k -> Type) :: Bool where + CheckNamedSum (D1 _ f) = CheckNamedSum f + CheckNamedSum (f :+: g) = CheckConst f || CheckConst g + CheckNamedSum _ = 'False + +-- | Check if Sum type has named fields at least for one of the Constructors. +type family CheckConst (f :: k -> Type) :: Bool where + CheckConst (f :+: g) = CheckConst f || CheckConst g + CheckConst (C1 _ f) = CheckConst f + CheckConst (S1 ('MetaSel ('Just _ ) _ _ _) _) = 'True + CheckConst (f :*: g) = CheckConst f || CheckConst g + CheckConst _ = 'False + +type family NamedSumError (t :: k) :: ErrorMessage where + NamedSumError t = + 'Text "'elm-street' doesn't support Sum types with records." + ':$$: 'Text "But '" ':<>: 'ShowType t ':<>: 'Text "' has records." diff --git a/src/Elm/Print.hs b/src/Elm/Print.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Print.hs @@ -0,0 +1,675 @@ +{- | This module defines prettyprinter for 'ElmDefinition' type. +and exports the function to represent it in the convenient way. +-} + +module Elm.Print + ( prettyShowDefinition + , prettyShowEncoder + , prettyShowDecoder + + -- * Standard missing encoders + , encodeMaybe + , encodeEither + , encodePair + + -- * Standard missing decoders + , decodeEnum + , decodeChar + , decodeEither + , decodePair + + -- * Internal functions + , elmAliasDoc + , elmTypeDoc + ) where + +import Data.List.NonEmpty (NonEmpty ((:|)), toList) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc, 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 <+> 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 <+> "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 length elmConstructorFields of + 0 -> "D.succeed" <+> cName + n -> "D.field \"contents\" <| D.map" <> mapNum n <+> 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)" + ] + +{- +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"]] + +putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" ["a"] $ (ElmConstructor "Approved" [TypeName "String", TypeName "Int"]) :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [TypeName "a"]] +-} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn ("Test suite not yet implemented" :: String) diff --git a/types/Types.hs b/types/Types.hs new file mode 100644 --- /dev/null +++ b/types/Types.hs @@ -0,0 +1,166 @@ +{-# 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. +-} + +module Types + ( Types + , OneType (..) + , defaultOneType + + -- * All test types + , Prims (..) + , Id (..) + , Age (..) + , RequestStatus (..) + , User (..) + , Guest (..) + , UserRequest (..) + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Text (Text) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) +import Data.Word (Word32) +import Elm (Elm (..), ElmStreet (..), elmNewtype, elmStreetParseJson, elmStreetToJson) +import GHC.Generics (Generic) + + +data Prims = Prims + { primsUnit :: () + , primsBool :: Bool + , primsChar :: Char + , primsInt :: Int + , primsFloat :: Double + , primsString :: String + , primsTime :: UTCTime + , primsMaybe :: Maybe Word + , primsResult :: Either Int String + , primsPair :: (Char, Bool) + , primsList :: [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) + deriving newtype (FromJSON, ToJSON) + +instance Elm (Id a) where + toElmDefinition _ = elmNewtype @Text "Id" "unId" + +newtype Age = Age + { unAge :: Int + } deriving (Generic, Eq, Show) + deriving anyclass (Elm) + deriving newtype (FromJSON, ToJSON) + +data RequestStatus + = Approved + | Rejected + | Reviewing + deriving (Generic, Eq, Show) + deriving anyclass (Elm, FromJSON, ToJSON) + +data User = User + { userId :: Id User + , userName :: Text + , userAge :: Age + , userStatus :: RequestStatus + } deriving (Generic, Eq, Show) + deriving anyclass (Elm) + +instance ToJSON User where toJSON = elmStreetToJson +instance FromJSON User where parseJSON = elmStreetParseJson + +data Guest + = Regular Text Int + | Visitor Text + | Blocked + deriving (Generic, Eq, Show) + deriving anyclass (Elm, FromJSON, ToJSON) + +data UserRequest = UserRequest + { userRequestIds :: [Id User] + , userRequestLimit :: Word32 + , userRequestExample :: Maybe (Either User Guest) + } deriving (Generic, Eq, Show) + deriving anyclass (Elm) + +instance ToJSON UserRequest where toJSON = elmStreetToJson +instance FromJSON UserRequest where parseJSON = elmStreetParseJson + +-- | All test types together in one type to play with. +data OneType = OneType + { oneTypePrims :: Prims + , oneTypeId :: Id OneType + , oneTypeAge :: Age + , oneTypeRequestStatus :: RequestStatus + , oneTypeUser :: User + , oneTypeGuest :: Guest + , oneTypeUserRequest :: UserRequest + } deriving (Generic, Eq, Show) + deriving anyclass (Elm) + +instance ToJSON OneType where toJSON = elmStreetToJson +instance FromJSON OneType where parseJSON = elmStreetParseJson + +-- | Type level list of all test types. +type Types = + '[ Prims + , Id () + , Age + , RequestStatus + , User + , Guest + , UserRequest + , OneType + ] + + +defaultOneType :: OneType +defaultOneType = OneType + { oneTypePrims = defaultPrims + , oneTypeId = Id "myId" + , oneTypeAge = Age 18 + , oneTypeRequestStatus = Reviewing + , oneTypeUser = User (Id "1") "not-me" (Age 100) Approved + , oneTypeGuest = Regular "nice" 7 + , oneTypeUserRequest = defaultUserRequest + } + where + defaultPrims :: Prims + defaultPrims = Prims + { primsUnit = () + , primsBool = True + , primsChar = 'a' + , primsInt = 42 + , primsFloat = 36.6 + , primsString = "heh" + , primsTime = UTCTime (fromGregorian 2019 2 22) 0 + , primsMaybe = Just 12 + , primsResult = Left 666 + , primsPair = ('o', False) + , primsList = [1..5] + } + + defaultUserRequest :: UserRequest + defaultUserRequest = UserRequest + { userRequestIds = [Id "1", Id "2"] + , userRequestLimit = 123 + , userRequestExample = Just (Right Blocked) + }