From 214537e6ccda46fb3ac2ab34a05310972f40aa3f Mon Sep 17 00:00:00 2001 From: Matt Bray Date: Tue, 24 Jan 2017 22:21:50 +0000 Subject: [PATCH 01/21] Add moduleSpec and renderType functions. --- README.md | 16 ++++------------ src/Elm/Common.hs | 25 ++++++++++++++++++++++++- src/Elm/Decoder.hs | 20 +++++++++++++++----- src/Elm/Encoder.hs | 22 +++++++++++++++------- src/Elm/File.hs | 25 +++++++++++++++++++++++-- src/Elm/Record.hs | 17 +++++++++++------ test/CommentEncoder.elm | 4 ++-- test/CommentEncoderWithOptions.elm | 4 ++-- test/ExportSpec.hs | 26 +++++++++++++++++++++++--- 9 files changed, 119 insertions(+), 40 deletions(-) diff --git a/README.md b/README.md index 08053ab..0934908 100644 --- a/README.md +++ b/README.md @@ -42,13 +42,10 @@ import Elm spec :: Spec spec = - Spec - ["Db", "Types"] - [ "import Json.Decode exposing (..)" - , "import Json.Decode.Pipeline exposing (..)" - , toElmTypeSource (Proxy :: Proxy Person) - , toElmDecoderSource (Proxy :: Proxy Person) - ] + moduleSpec ["Db", "Types"] $ do + renderType (Proxy :: Proxy Person) + renderDecoder (Proxy :: Proxy Person) + renderEncoder (Proxy :: Proxy Person) main :: IO () main = specsToDir [spec] "some/where/output" @@ -57,11 +54,6 @@ main = specsToDir [spec] "some/where/output" Run this and the directory `some/where/output` will be created, and under that the Elm source file `Db/Types.elm` will be found. -All the hard work here is done by `toElmTypeSource` and -`toElmDecoderSource`. The `Spec` code is just wrapping to make it easy -to create a complete Elm file from the meat that `ElmType` gives -you. - ### Required Elm Packages The decoders we produce require these extra Elm packages installed: diff --git a/src/Elm/Common.hs b/src/Elm/Common.hs index 6963ab8..c36fab0 100644 --- a/src/Elm/Common.hs +++ b/src/Elm/Common.hs @@ -2,11 +2,14 @@ module Elm.Common where +import Control.Monad.Reader +import Control.Monad.Writer import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) -import Data.Monoid import Data.Text (Text) import qualified Data.Text.Lazy as LT import Formatting hiding (text) +import Data.Set (Set) +import qualified Data.Set as S data Options = Options { fieldLabelModifier :: Text -> Text @@ -33,3 +36,23 @@ stext = text . LT.fromStrict spaceparens :: Doc -> Doc spaceparens doc = "(" <+> doc <+> ")" + +-- + +type RenderM a = + WriterT ( Set Text -- The set of required imports + , [Text] -- Declarations + ) + (Reader Options) a + +{-| Add an import to the set. +-} +require :: Text -> RenderM () +require dep = tell (S.singleton dep, []) + +{-| Take the result of a RenderM computation and put it into the Writer's +declarations. +-} +collectDeclaration :: RenderM Doc -> RenderM () +collectDeclaration = + mapWriterT (fmap (\(defn, (imports, _)) -> ((), (imports, [pprinter defn])))) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 5883961..cf37669 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -8,20 +8,21 @@ module Elm.Decoder , toElmDecoderRefWith , toElmDecoderSource , toElmDecoderSourceWith + , renderDecoder ) where import Control.Monad.Reader -import Data.Monoid +import Control.Monad.Writer import qualified Data.Text as T import Elm.Common import Elm.Type import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) class HasDecoder a where - render :: a -> Reader Options Doc + render :: a -> RenderM Doc class HasDecoderRef a where - renderRef :: a -> Reader Options Doc + renderRef :: a -> RenderM Doc instance HasDecoder ElmDatatype where render d@(ElmDatatype name constructor) = do @@ -62,6 +63,7 @@ instance HasDecoderRef ElmPrimitive where dt <- renderRef datatype return . parens $ "list" <+> dt renderRef (EDict key value) = do + require "Dict" d <- renderRef (EList (ElmPrimitive (ETuple2 (ElmPrimitive key) value))) return . parens $ "map Dict.fromList" <+> d renderRef (EMaybe datatype) = do @@ -83,7 +85,8 @@ instance HasDecoderRef ElmPrimitive where toElmDecoderRefWith :: ElmType a => Options -> a -> T.Text -toElmDecoderRefWith options x = pprinter $ runReader (renderRef (toElmType x)) options +toElmDecoderRefWith options x = + pprinter . fst $ runReader (runWriterT (renderRef (toElmType x))) options toElmDecoderRef :: ElmType a @@ -93,9 +96,16 @@ toElmDecoderRef = toElmDecoderRefWith defaultOptions toElmDecoderSourceWith :: ElmType a => Options -> a -> T.Text -toElmDecoderSourceWith options x = pprinter $ runReader (render (toElmType x)) options +toElmDecoderSourceWith options x = + pprinter . fst $ runReader (runWriterT (render (toElmType x))) options toElmDecoderSource :: ElmType a => a -> T.Text toElmDecoderSource = toElmDecoderSourceWith defaultOptions + +renderDecoder :: ElmType a => a -> RenderM () +renderDecoder x = + require "Json.Decode exposing (..)" >> + require "Json.Decode.Pipeline exposing (..)" >> + (collectDeclaration . render . toElmType $ x) diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs index 1ec4ff6..495c7ef 100644 --- a/src/Elm/Encoder.hs +++ b/src/Elm/Encoder.hs @@ -5,20 +5,21 @@ module Elm.Encoder , toElmEncoderRefWith , toElmEncoderSource , toElmEncoderSourceWith + , renderEncoder ) where import Control.Monad.Reader -import Data.Monoid +import Control.Monad.Writer import qualified Data.Text as T import Elm.Common import Elm.Type import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) class HasEncoder a where - render :: a -> Reader Options Doc + render :: a -> RenderM Doc class HasEncoderRef a where - renderRef :: a -> Reader Options Doc + renderRef :: a -> RenderM Doc instance HasEncoder ElmDatatype where render d@(ElmDatatype name constructor) = do @@ -70,17 +71,19 @@ instance HasEncoderRef ElmPrimitive where renderRef (ETuple2 x y) = do dx <- renderRef x dy <- renderRef y - return . parens $ "tuple2" <+> dx <+> dy + require "Exts.Json.Encode" + return . parens $ "Exts.Json.Encode.tuple2" <+> dx <+> dy renderRef (EDict k v) = do dk <- renderRef k dv <- renderRef v - return . parens $ "dict" <+> dk <+> dv + require "Exts.Json.Encode" + return . parens $ "Exts.Json.Encode.dict" <+> dk <+> dv toElmEncoderRefWith :: ElmType a => Options -> a -> T.Text toElmEncoderRefWith options x = - pprinter $ runReader (renderRef (toElmType x)) options + pprinter . fst $ runReader (runWriterT (renderRef (toElmType x))) options toElmEncoderRef :: ElmType a @@ -91,9 +94,14 @@ toElmEncoderSourceWith :: ElmType a => Options -> a -> T.Text toElmEncoderSourceWith options x = - pprinter $ runReader (render (toElmType x)) options + pprinter . fst $ runReader (runWriterT (render (toElmType x))) options toElmEncoderSource :: ElmType a => a -> T.Text toElmEncoderSource = toElmEncoderSourceWith defaultOptions + +renderEncoder :: ElmType a => a -> RenderM () +renderEncoder x = + require "Json.Encode" >> + (collectDeclaration . render . toElmType $ x) diff --git a/src/Elm/File.hs b/src/Elm/File.hs index 5a664f5..9464697 100644 --- a/src/Elm/File.hs +++ b/src/Elm/File.hs @@ -3,13 +3,18 @@ module Elm.File ( Spec(..) , specsToDir + , moduleSpec + , moduleSpecWith ) where +import Control.Monad.Reader +import Control.Monad.Writer import Data.List -import Data.Monoid +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T +import Elm.Common import Formatting as F import System.Directory @@ -19,7 +24,7 @@ makePath = T.intercalate "/" data Spec = Spec { namespace :: [Text] , declarations :: [Text] - } + } deriving (Eq, Show) pathForSpec :: FilePath -> Spec -> [Text] pathForSpec rootDir spec = T.pack rootDir : namespace spec @@ -46,3 +51,19 @@ specsToDir :: [Spec] -> FilePath -> IO () specsToDir specs rootDir = mapM_ processSpec specs where processSpec = ensureDirectory rootDir >> specToFile rootDir + +moduleSpecWith :: Options -> [Text] -> RenderM () -> Spec +moduleSpecWith options ns m = + let + (imports, defns) = + runReader (execWriterT m) options + in + Spec + { namespace = ns + , declarations = + (T.intercalate "\n" . fmap ("import " <>) . S.toAscList $ imports) + : defns + } + +moduleSpec :: [Text] -> RenderM () -> Spec +moduleSpec = moduleSpecWith defaultOptions diff --git a/src/Elm/Record.hs b/src/Elm/Record.hs index 97eded0..b3063a7 100644 --- a/src/Elm/Record.hs +++ b/src/Elm/Record.hs @@ -5,20 +5,21 @@ module Elm.Record , toElmTypeRefWith , toElmTypeSource , toElmTypeSourceWith + , renderType ) where import Control.Monad.Reader -import Data.Monoid +import Control.Monad.Writer import qualified Data.Text as T import Elm.Common import Elm.Type import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) class HasType a where - render :: a -> Reader Options Doc + render :: a -> RenderM Doc class HasTypeRef a where - renderRef :: a -> Reader Options Doc + renderRef :: a -> RenderM Doc instance HasType ElmDatatype where render d@(ElmDatatype _ constructor@(RecordConstructor _ _)) = do @@ -71,11 +72,12 @@ instance HasTypeRef ElmPrimitive where dt <- renderRef datatype return $ "Maybe" <+> parens dt renderRef (EDict k v) = do + require "Dict" dk <- renderRef k dv <- renderRef v return $ "Dict" <+> parens dk <+> parens dv renderRef EInt = pure "Int" - renderRef EDate = pure "Date" + renderRef EDate = require "Date" >> pure "Date" renderRef EBool = pure "Bool" renderRef EChar = pure "Char" renderRef EString = pure "String" @@ -86,7 +88,7 @@ toElmTypeRefWith :: ElmType a => Options -> a -> T.Text toElmTypeRefWith options x = - pprinter $ runReader (renderRef (toElmType x)) options + pprinter . fst $ runReader (runWriterT (renderRef (toElmType x))) options toElmTypeRef :: ElmType a @@ -97,9 +99,12 @@ toElmTypeSourceWith :: ElmType a => Options -> a -> T.Text toElmTypeSourceWith options x = - pprinter $ runReader (render (toElmType x)) options + pprinter . fst $ runReader (runWriterT (render (toElmType x))) options toElmTypeSource :: ElmType a => a -> T.Text toElmTypeSource = toElmTypeSourceWith defaultOptions + +renderType :: ElmType a => a -> RenderM () +renderType = collectDeclaration . render . toElmType diff --git a/test/CommentEncoder.elm b/test/CommentEncoder.elm index bc916b9..0acc9be 100644 --- a/test/CommentEncoder.elm +++ b/test/CommentEncoder.elm @@ -10,8 +10,8 @@ encodeComment x = Json.Encode.object [ ( "postId", Json.Encode.int x.postId ) , ( "text", Json.Encode.string x.text ) - , ( "mainCategories", (tuple2 Json.Encode.string Json.Encode.string) x.mainCategories ) + , ( "mainCategories", (Exts.Json.Encode.tuple2 Json.Encode.string Json.Encode.string) x.mainCategories ) , ( "published", Json.Encode.bool x.published ) , ( "created", (Json.Encode.string << toString) x.created ) - , ( "tags", (dict Json.Encode.string Json.Encode.int) x.tags ) + , ( "tags", (Exts.Json.Encode.dict Json.Encode.string Json.Encode.int) x.tags ) ] diff --git a/test/CommentEncoderWithOptions.elm b/test/CommentEncoderWithOptions.elm index 7f314e1..5769e68 100644 --- a/test/CommentEncoderWithOptions.elm +++ b/test/CommentEncoderWithOptions.elm @@ -10,8 +10,8 @@ encodeComment x = Json.Encode.object [ ( "commentPostId", Json.Encode.int x.postId ) , ( "commentText", Json.Encode.string x.text ) - , ( "commentMainCategories", (tuple2 Json.Encode.string Json.Encode.string) x.mainCategories ) + , ( "commentMainCategories", (Exts.Json.Encode.tuple2 Json.Encode.string Json.Encode.string) x.mainCategories ) , ( "commentPublished", Json.Encode.bool x.published ) , ( "commentCreated", (Json.Encode.string << toString) x.created ) - , ( "commentTags", (dict Json.Encode.string Json.Encode.int) x.tags ) + , ( "commentTags", (Exts.Json.Encode.dict Json.Encode.string Json.Encode.int) x.tags ) ] diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs index 650dc1c..7e753fa 100644 --- a/test/ExportSpec.hs +++ b/test/ExportSpec.hs @@ -12,7 +12,7 @@ import Data.IntMap import Data.Map import Data.Monoid import Data.Proxy -import Data.Text hiding (lines, unlines) +import Data.Text hiding (head, lines, unlines) import Data.Time import Elm import GHC.Generics @@ -76,6 +76,7 @@ spec = do toElmTypeSpec toElmDecoderSpec toElmEncoderSpec + moduleSpecsSpec toElmTypeSpec :: Hspec.Spec toElmTypeSpec = @@ -356,10 +357,29 @@ toElmEncoderSpec = "(Json.Encode.list << List.map (Maybe.withDefault Json.Encode.null << Maybe.map Json.Encode.string))" it "toElmEncoderRef (Map String (Maybe String))" $ toElmEncoderRef (Proxy :: Proxy (Map String (Maybe String))) `shouldBe` - "(dict Json.Encode.string (Maybe.withDefault Json.Encode.null << Maybe.map Json.Encode.string))" + "(Exts.Json.Encode.dict Json.Encode.string (Maybe.withDefault Json.Encode.null << Maybe.map Json.Encode.string))" it "toElmEncoderRef (IntMap (Maybe String))" $ toElmEncoderRef (Proxy :: Proxy (IntMap (Maybe String))) `shouldBe` - "(dict Json.Encode.int (Maybe.withDefault Json.Encode.null << Maybe.map Json.Encode.string))" + "(Exts.Json.Encode.dict Json.Encode.int (Maybe.withDefault Json.Encode.null << Maybe.map Json.Encode.string))" + +moduleSpecsSpec :: Hspec.Spec +moduleSpecsSpec = + describe "Generating a module Spec" $ do + let mySpec = + moduleSpec ["My", "Module"] $ do + renderType (Proxy :: Proxy Post) + renderDecoder (Proxy :: Proxy Post) + renderType (Proxy :: Proxy Comment) + it "sets the module namespace" $ + namespace mySpec `shouldBe` ["My", "Module"] + it "inserts the correct imports" $ + head (declarations mySpec) `shouldBe` + intercalate "\n" + [ "import Date" + , "import Dict" + , "import Json.Decode exposing (..)" + , "import Json.Decode.Pipeline exposing (..)" + ] shouldMatchTypeSource :: ElmType a From 66f7ed139b9f27d57d20361b5f0b4e41a17c71db Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 10 Feb 2017 10:32:29 +0000 Subject: [PATCH 02/21] Readme updates. --- README.md | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 0934908..5ea01f7 100644 --- a/README.md +++ b/README.md @@ -43,6 +43,7 @@ import Elm spec :: Spec spec = moduleSpec ["Db", "Types"] $ do + require "Date exposing (Date)" renderType (Proxy :: Proxy Person) renderDecoder (Proxy :: Proxy Person) renderEncoder (Proxy :: Proxy Person) @@ -81,6 +82,15 @@ stack test --file-watch ## Change Log +### V0.6.x +Updated to Elm 0.18. + +### V0.5.x +??? + +### V0.4.x +??? + ### V0.3.0.0 * Renamed `ToElmType` to `ElmType`, for brevity. @@ -92,8 +102,8 @@ stack test --file-watch ## Status -Alpha. The author is using it in production, but it is not yet -expected to work for every reasonable case. +Beta. Several people are using it in production, reliably, but it is +not yet expected to work for every reasonable datatype. There are some Haskell datatypes that cannot be represented in Elm. Obviously we will not support those. But there are some which are From 2a0e578f93a57f7752ab4a705366cfd60911f49f Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Sat, 11 Feb 2017 21:32:36 +0000 Subject: [PATCH 03/21] Exporting Elm.Common.require, for the new moduleSpec code. --- src/Elm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm.hs b/src/Elm.hs index 854ba3e..0e04e3d 100644 --- a/src/Elm.hs +++ b/src/Elm.hs @@ -2,7 +2,7 @@ module Elm ( module X ) where -import Elm.Common as X (Options(..), defaultOptions) +import Elm.Common as X (Options(..), defaultOptions, require) import Elm.Decoder as X import Elm.Encoder as X import Elm.File as X From b300274c80a15eebeca0de6819ccb5e166bc469e Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Sat, 11 Feb 2017 21:34:36 +0000 Subject: [PATCH 04/21] Whitespace changes. --- src/Elm/Common.hs | 23 ++++++++++------------- src/Elm/Decoder.hs | 4 +++- src/Elm/Encoder.hs | 7 ++++--- src/Elm/File.hs | 39 ++++++++++++++++++--------------------- src/Elm/Record.hs | 4 +++- src/Elm/Type.hs | 32 ++++++++++++++++---------------- 6 files changed, 54 insertions(+), 55 deletions(-) diff --git a/src/Elm/Common.hs b/src/Elm/Common.hs index c36fab0..75a6e2a 100644 --- a/src/Elm/Common.hs +++ b/src/Elm/Common.hs @@ -2,14 +2,14 @@ module Elm.Common where -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.Reader +import Control.Monad.Writer +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import Formatting hiding (text) import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) -import Data.Text (Text) -import qualified Data.Text.Lazy as LT -import Formatting hiding (text) -import Data.Set (Set) -import qualified Data.Set as S data Options = Options { fieldLabelModifier :: Text -> Text @@ -38,12 +38,9 @@ spaceparens :: Doc -> Doc spaceparens doc = "(" <+> doc <+> ")" -- - -type RenderM a = - WriterT ( Set Text -- The set of required imports - , [Text] -- Declarations - ) - (Reader Options) a +type RenderM a = WriterT (Set Text -- The set of required imports + , [Text] -- Declarations + ) (Reader Options) a {-| Add an import to the set. -} diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index cf37669..9204a63 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -104,7 +104,9 @@ toElmDecoderSource => a -> T.Text toElmDecoderSource = toElmDecoderSourceWith defaultOptions -renderDecoder :: ElmType a => a -> RenderM () +renderDecoder + :: ElmType a + => a -> RenderM () renderDecoder x = require "Json.Decode exposing (..)" >> require "Json.Decode.Pipeline exposing (..)" >> diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs index 495c7ef..ea44711 100644 --- a/src/Elm/Encoder.hs +++ b/src/Elm/Encoder.hs @@ -101,7 +101,8 @@ toElmEncoderSource => a -> T.Text toElmEncoderSource = toElmEncoderSourceWith defaultOptions -renderEncoder :: ElmType a => a -> RenderM () +renderEncoder + :: ElmType a + => a -> RenderM () renderEncoder x = - require "Json.Encode" >> - (collectDeclaration . render . toElmType $ x) + require "Json.Encode" >> (collectDeclaration . render . toElmType $ x) diff --git a/src/Elm/File.hs b/src/Elm/File.hs index 9464697..3f75233 100644 --- a/src/Elm/File.hs +++ b/src/Elm/File.hs @@ -7,22 +7,22 @@ module Elm.File , moduleSpecWith ) where -import Control.Monad.Reader -import Control.Monad.Writer -import Data.List -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Elm.Common -import Formatting as F -import System.Directory +import Control.Monad.Reader +import Control.Monad.Writer +import Data.List +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Elm.Common +import Formatting as F +import System.Directory makePath :: [Text] -> Text makePath = T.intercalate "/" data Spec = Spec - { namespace :: [Text] + { namespace :: [Text] , declarations :: [Text] } deriving (Eq, Show) @@ -54,16 +54,13 @@ specsToDir specs rootDir = mapM_ processSpec specs moduleSpecWith :: Options -> [Text] -> RenderM () -> Spec moduleSpecWith options ns m = - let - (imports, defns) = - runReader (execWriterT m) options - in - Spec - { namespace = ns - , declarations = - (T.intercalate "\n" . fmap ("import " <>) . S.toAscList $ imports) - : defns - } + let (imports, defns) = runReader (execWriterT m) options + in Spec + { namespace = ns + , declarations = + (T.intercalate "\n" . fmap ("import " <>) . S.toAscList $ imports) : + defns + } moduleSpec :: [Text] -> RenderM () -> Spec moduleSpec = moduleSpecWith defaultOptions diff --git a/src/Elm/Record.hs b/src/Elm/Record.hs index b3063a7..1cebfcb 100644 --- a/src/Elm/Record.hs +++ b/src/Elm/Record.hs @@ -106,5 +106,7 @@ toElmTypeSource => a -> T.Text toElmTypeSource = toElmTypeSourceWith defaultOptions -renderType :: ElmType a => a -> RenderM () +renderType + :: ElmType a + => a -> RenderM () renderType = collectDeclaration . render . toElmType diff --git a/src/Elm/Type.hs b/src/Elm/Type.hs index 7a0d39c..dccbfb6 100644 --- a/src/Elm/Type.hs +++ b/src/Elm/Type.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} module Elm.Type where -import Data.Int (Int16, Int32, Int64, Int8) -import Data.IntMap -import Data.Map -import Data.Proxy -import Data.Text -import Data.Time -import GHC.Generics -import Prelude +import Data.Int (Int16, Int32, Int64, Int8) +import Data.IntMap +import Data.Map +import Data.Proxy +import Data.Text +import Data.Time +import GHC.Generics +import Prelude data ElmDatatype = ElmDatatype Text @@ -104,7 +104,7 @@ instance (Selector s, GenericElmValue a) => GenericElmValue (S1 s a) where genericToElmValue selector = case selName selector of - "" -> genericToElmValue (undefined :: a p) + "" -> genericToElmValue (undefined :: a p) name -> ElmField (pack name) (genericToElmValue (undefined :: a p)) instance (GenericElmValue f, GenericElmValue g) => @@ -122,7 +122,7 @@ instance ElmType a => genericToElmValue _ = case toElmType (Proxy :: Proxy a) of ElmPrimitive primitive -> ElmPrimitiveRef primitive - ElmDatatype name _ -> ElmRef name + ElmDatatype name _ -> ElmRef name instance ElmType a => ElmType [a] where From 872576ab9c6beaaef733a43045502a150d207dda Mon Sep 17 00:00:00 2001 From: Matt Bray Date: Sun, 12 Feb 2017 16:38:33 +0000 Subject: [PATCH 05/21] Use Control.Monad.RWS. --- src/Elm/Common.hs | 11 +++++------ src/Elm/Decoder.hs | 7 +++---- src/Elm/Encoder.hs | 7 +++---- src/Elm/File.hs | 5 ++--- src/Elm/Record.hs | 7 +++---- 5 files changed, 16 insertions(+), 21 deletions(-) diff --git a/src/Elm/Common.hs b/src/Elm/Common.hs index 75a6e2a..b574770 100644 --- a/src/Elm/Common.hs +++ b/src/Elm/Common.hs @@ -2,8 +2,7 @@ module Elm.Common where -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.RWS import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) @@ -38,9 +37,9 @@ spaceparens :: Doc -> Doc spaceparens doc = "(" <+> doc <+> ")" -- -type RenderM a = WriterT (Set Text -- The set of required imports - , [Text] -- Declarations - ) (Reader Options) a +type RenderM = RWS Options (Set Text -- The set of required imports + , [Text] -- Generated declarations + ) () {-| Add an import to the set. -} @@ -52,4 +51,4 @@ declarations. -} collectDeclaration :: RenderM Doc -> RenderM () collectDeclaration = - mapWriterT (fmap (\(defn, (imports, _)) -> ((), (imports, [pprinter defn])))) + mapRWS ((\(defn, (), (imports, _)) -> ((), (), (imports, [pprinter defn])))) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 9204a63..0b604a5 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -11,8 +11,7 @@ module Elm.Decoder , renderDecoder ) where -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.RWS import qualified Data.Text as T import Elm.Common import Elm.Type @@ -86,7 +85,7 @@ toElmDecoderRefWith :: ElmType a => Options -> a -> T.Text toElmDecoderRefWith options x = - pprinter . fst $ runReader (runWriterT (renderRef (toElmType x))) options + pprinter . fst $ evalRWS (renderRef (toElmType x)) options () toElmDecoderRef :: ElmType a @@ -97,7 +96,7 @@ toElmDecoderSourceWith :: ElmType a => Options -> a -> T.Text toElmDecoderSourceWith options x = - pprinter . fst $ runReader (runWriterT (render (toElmType x))) options + pprinter . fst $ evalRWS (render (toElmType x)) options () toElmDecoderSource :: ElmType a diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs index ea44711..5b8d1ac 100644 --- a/src/Elm/Encoder.hs +++ b/src/Elm/Encoder.hs @@ -8,8 +8,7 @@ module Elm.Encoder , renderEncoder ) where -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.RWS import qualified Data.Text as T import Elm.Common import Elm.Type @@ -83,7 +82,7 @@ toElmEncoderRefWith :: ElmType a => Options -> a -> T.Text toElmEncoderRefWith options x = - pprinter . fst $ runReader (runWriterT (renderRef (toElmType x))) options + pprinter . fst $ evalRWS (renderRef (toElmType x)) options () toElmEncoderRef :: ElmType a @@ -94,7 +93,7 @@ toElmEncoderSourceWith :: ElmType a => Options -> a -> T.Text toElmEncoderSourceWith options x = - pprinter . fst $ runReader (runWriterT (render (toElmType x))) options + pprinter . fst $ evalRWS (render (toElmType x)) options () toElmEncoderSource :: ElmType a diff --git a/src/Elm/File.hs b/src/Elm/File.hs index 3f75233..4cadbb4 100644 --- a/src/Elm/File.hs +++ b/src/Elm/File.hs @@ -7,8 +7,7 @@ module Elm.File , moduleSpecWith ) where -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.RWS import Data.List import qualified Data.Set as S import Data.Text (Text) @@ -54,7 +53,7 @@ specsToDir specs rootDir = mapM_ processSpec specs moduleSpecWith :: Options -> [Text] -> RenderM () -> Spec moduleSpecWith options ns m = - let (imports, defns) = runReader (execWriterT m) options + let ((), (imports, defns)) = execRWS m options () in Spec { namespace = ns , declarations = diff --git a/src/Elm/Record.hs b/src/Elm/Record.hs index 1cebfcb..3af1a5b 100644 --- a/src/Elm/Record.hs +++ b/src/Elm/Record.hs @@ -8,8 +8,7 @@ module Elm.Record , renderType ) where -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.RWS import qualified Data.Text as T import Elm.Common import Elm.Type @@ -88,7 +87,7 @@ toElmTypeRefWith :: ElmType a => Options -> a -> T.Text toElmTypeRefWith options x = - pprinter . fst $ runReader (runWriterT (renderRef (toElmType x))) options + pprinter . fst $ evalRWS (renderRef (toElmType x)) options () toElmTypeRef :: ElmType a @@ -99,7 +98,7 @@ toElmTypeSourceWith :: ElmType a => Options -> a -> T.Text toElmTypeSourceWith options x = - pprinter . fst $ runReader (runWriterT (render (toElmType x))) options + pprinter . fst $ evalRWS (render (toElmType x)) options () toElmTypeSource :: ElmType a From b445ebfca7db0eba18be90639deb254a1174b140 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 21 Feb 2017 23:13:02 +0000 Subject: [PATCH 06/21] Whitespace changes. --- test/ExportSpec.hs | 60 ++++++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 29 deletions(-) diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs index 7e753fa..4abeb84 100644 --- a/test/ExportSpec.hs +++ b/test/ExportSpec.hs @@ -1,46 +1,46 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module ExportSpec where -import qualified Data.Algorithm.Diff as Diff +import qualified Data.Algorithm.Diff as Diff import qualified Data.Algorithm.DiffOutput as DiffOutput -import Data.Char -import Data.Int -import Data.IntMap -import Data.Map -import Data.Monoid -import Data.Proxy -import Data.Text hiding (head, lines, unlines) -import Data.Time -import Elm -import GHC.Generics -import Test.Hspec hiding (Spec) -import Test.Hspec as Hspec -import Test.HUnit (Assertion, assertBool) -import Text.Printf +import Data.Char +import Data.Int +import Data.IntMap +import Data.Map +import Data.Monoid +import Data.Proxy +import Data.Text hiding (head, lines, unlines) +import Data.Time +import Elm +import GHC.Generics +import Test.HUnit (Assertion, assertBool) +import Test.Hspec hiding (Spec) +import Test.Hspec as Hspec +import Text.Printf -- Debugging hint: -- ghci> import GHC.Generics -- ghci> :kind! Rep Post -- ... data Post = Post - { id :: Int - , name :: String - , age :: Maybe Double + { id :: Int + , name :: String + , age :: Maybe Double , comments :: [Comment] , promoted :: Maybe Comment - , author :: Maybe String + , author :: Maybe String } deriving (Generic, ElmType) data Comment = Comment - { postId :: Int - , text :: Text + { postId :: Int + , text :: Text , mainCategories :: (String, String) - , published :: Bool - , created :: UTCTime - , tags :: Map String Int + , published :: Bool + , created :: UTCTime + , tags :: Map String Int } deriving (Generic, ElmType) data Position @@ -173,7 +173,8 @@ toElmTypeSpec = it "toElmTypeRef [Comment]" $ toElmTypeRef (Proxy :: Proxy [Comment]) `shouldBe` "List (Comment)" it "toElmTypeRef (Comment, String)" $ - toElmTypeRef (Proxy :: Proxy (Comment, String)) `shouldBe` "(Comment, String)" + toElmTypeRef (Proxy :: Proxy (Comment, String)) `shouldBe` + "(Comment, String)" it "toElmTypeRef String" $ toElmTypeRef (Proxy :: Proxy String) `shouldBe` "String" it "toElmTypeRef (Maybe String)" $ @@ -374,7 +375,8 @@ moduleSpecsSpec = namespace mySpec `shouldBe` ["My", "Module"] it "inserts the correct imports" $ head (declarations mySpec) `shouldBe` - intercalate "\n" + intercalate + "\n" [ "import Date" , "import Dict" , "import Json.Decode exposing (..)" @@ -414,7 +416,7 @@ shouldBeDiff a (fpath, b) = initCap :: Text -> Text initCap t = case uncons t of - Nothing -> t + Nothing -> t Just (c, cs) -> cons (Data.Char.toUpper c) cs withPrefix :: Text -> Text -> Text From 0ba463e8792ca94778b5e6e2fd8c23d98dca794d Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 21 Feb 2017 23:11:55 +0000 Subject: [PATCH 07/21] Replacing some usages `>>` with do-blocks. It's a small change, but I find it more readable. --- src/Elm/Decoder.hs | 8 ++++---- src/Elm/Encoder.hs | 5 +++-- src/Elm/Record.hs | 4 +++- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 0b604a5..2f92f59 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -106,7 +106,7 @@ toElmDecoderSource = toElmDecoderSourceWith defaultOptions renderDecoder :: ElmType a => a -> RenderM () -renderDecoder x = - require "Json.Decode exposing (..)" >> - require "Json.Decode.Pipeline exposing (..)" >> - (collectDeclaration . render . toElmType $ x) +renderDecoder x = do + require "Json.Decode exposing (..)" + require "Json.Decode.Pipeline exposing (..)" + collectDeclaration . render . toElmType $ x diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs index 5b8d1ac..16de03b 100644 --- a/src/Elm/Encoder.hs +++ b/src/Elm/Encoder.hs @@ -103,5 +103,6 @@ toElmEncoderSource = toElmEncoderSourceWith defaultOptions renderEncoder :: ElmType a => a -> RenderM () -renderEncoder x = - require "Json.Encode" >> (collectDeclaration . render . toElmType $ x) +renderEncoder x = do + require "Json.Encode" + collectDeclaration . render . toElmType $ x diff --git a/src/Elm/Record.hs b/src/Elm/Record.hs index 3af1a5b..6789531 100644 --- a/src/Elm/Record.hs +++ b/src/Elm/Record.hs @@ -76,7 +76,9 @@ instance HasTypeRef ElmPrimitive where dv <- renderRef v return $ "Dict" <+> parens dk <+> parens dv renderRef EInt = pure "Int" - renderRef EDate = require "Date" >> pure "Date" + renderRef EDate = do + require "Date" + pure "Date" renderRef EBool = pure "Bool" renderRef EChar = pure "Char" renderRef EString = pure "String" From a3df6c74690c93944717cd33191060195b7482f2 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 21 Feb 2017 23:13:24 +0000 Subject: [PATCH 08/21] Replacing the use of Json.Decode.maybe with .nullable. This more accurately reflects our intent. With `nullable` the value must decode exactly, or be `null`. With `maybe` the value must decode exactly, you get a `Nothing` even if total junk is present. --- src/Elm/Decoder.hs | 2 +- test/ExportSpec.hs | 8 ++++---- test/PostDecoder.elm | 6 +++--- test/PostDecoderWithOptions.elm | 6 +++--- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 2f92f59..8b0acf4 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -67,7 +67,7 @@ instance HasDecoderRef ElmPrimitive where return . parens $ "map Dict.fromList" <+> d renderRef (EMaybe datatype) = do dt <- renderRef datatype - return . parens $ "maybe" <+> dt + return . parens $ "nullable" <+> dt renderRef (ETuple2 x y) = do dx <- renderRef x dy <- renderRef y diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs index 4abeb84..2561c0b 100644 --- a/test/ExportSpec.hs +++ b/test/ExportSpec.hs @@ -268,16 +268,16 @@ toElmDecoderSpec = toElmDecoderRef (Proxy :: Proxy String) `shouldBe` "string" it "toElmDecoderRef (Maybe String)" $ toElmDecoderRef (Proxy :: Proxy (Maybe String)) `shouldBe` - "(maybe string)" + "(nullable string)" it "toElmDecoderRef [Maybe String]" $ toElmDecoderRef (Proxy :: Proxy [Maybe String]) `shouldBe` - "(list (maybe string))" + "(list (nullable string))" it "toElmDecoderRef (Map String (Maybe String))" $ toElmDecoderRef (Proxy :: Proxy (Map String (Maybe String))) `shouldBe` - "(map Dict.fromList (list (map2 (,) (index 0 string) (index 1 (maybe string)))))" + "(map Dict.fromList (list (map2 (,) (index 0 string) (index 1 (nullable string)))))" it "toElmDecoderRef (IntMap (Maybe String))" $ toElmDecoderRef (Proxy :: Proxy (IntMap (Maybe String))) `shouldBe` - "(map Dict.fromList (list (map2 (,) (index 0 int) (index 1 (maybe string)))))" + "(map Dict.fromList (list (map2 (,) (index 0 int) (index 1 (nullable string)))))" toElmEncoderSpec :: Hspec.Spec toElmEncoderSpec = diff --git a/test/PostDecoder.elm b/test/PostDecoder.elm index 462d798..deeb35a 100644 --- a/test/PostDecoder.elm +++ b/test/PostDecoder.elm @@ -11,7 +11,7 @@ decodePost = decode Post |> required "id" int |> required "name" string - |> required "age" (maybe float) + |> required "age" (nullable float) |> required "comments" (list decodeComment) - |> required "promoted" (maybe decodeComment) - |> required "author" (maybe string) + |> required "promoted" (nullable decodeComment) + |> required "author" (nullable string) diff --git a/test/PostDecoderWithOptions.elm b/test/PostDecoderWithOptions.elm index c88acdb..9f8a8b6 100644 --- a/test/PostDecoderWithOptions.elm +++ b/test/PostDecoderWithOptions.elm @@ -11,7 +11,7 @@ decodePost = decode Post |> required "postId" int |> required "postName" string - |> required "postAge" (maybe float) + |> required "postAge" (nullable float) |> required "postComments" (list decodeComment) - |> required "postPromoted" (maybe decodeComment) - |> required "postAuthor" (maybe string) + |> required "postPromoted" (nullable decodeComment) + |> required "postAuthor" (nullable string) From a2599f142b6aff024e411b8479b13b68e83e13d4 Mon Sep 17 00:00:00 2001 From: Matt Bray Date: Sun, 5 Mar 2017 17:56:53 +0000 Subject: [PATCH 09/21] Add a contributing section to the Readme. --- README.md | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/README.md b/README.md index 5ea01f7..44c043e 100644 --- a/README.md +++ b/README.md @@ -80,6 +80,17 @@ stack build stack test --file-watch ``` +### Contributing guide + +Development happens on the `devel` branch. Pull requests target this branch. + +Generated Elm code adheres to the [`elm-format`][1] style. + +JSON encoders and decoders match the default behavior of [Aeson][2]. + +[1]: https://github.com/avh4/elm-format +[2]: https://hackage.haskell.org/package/aeson + ## Change Log ### V0.6.x From 7ca89b88393925ebd27ace8c919cec1fe0f511c0 Mon Sep 17 00:00:00 2001 From: Luke Taylor Date: Wed, 8 Mar 2017 00:41:54 +0000 Subject: [PATCH 10/21] Add HasElmComparable instance for Text --- src/Elm/Type.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Elm/Type.hs b/src/Elm/Type.hs index dccbfb6..7c2ea19 100644 --- a/src/Elm/Type.hs +++ b/src/Elm/Type.hs @@ -188,6 +188,9 @@ class HasElmComparable a where instance HasElmComparable String where toElmComparable _ = EString +instance HasElmComparable Text where + toElmComparable _ = EString + instance ElmType Int where toElmType _ = ElmPrimitive EInt From bad9f74e211fae26f95fda86bedcacdbba2c6ae2 Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sun, 26 Feb 2017 21:12:25 +0100 Subject: [PATCH 11/21] support for algebraic sum types --- src/Elm/Common.hs | 6 ++ src/Elm/Decoder.hs | 50 ++++++++++++++ src/Elm/Encoder.hs | 102 +++++++++++++++++++++++++++++ src/Elm/Record.hs | 27 ++++++-- src/Elm/Type.hs | 10 ++- test/ExportSpec.hs | 126 ++++++++++++++++++++++++++++++++++++ test/MonstrosityDecoder.elm | 14 ++++ test/MonstrosityEncoder.elm | 21 ++++++ test/MonstrosityType.elm | 7 ++ test/PositionDecoder.elm | 14 ++++ test/PositionEncoder.elm | 12 ++++ test/TimingDecoder.elm | 14 ++++ test/TimingEncoder.elm | 21 ++++++ test/UselessDecoder.elm | 11 ++++ 14 files changed, 430 insertions(+), 5 deletions(-) create mode 100644 test/MonstrosityDecoder.elm create mode 100644 test/MonstrosityEncoder.elm create mode 100644 test/MonstrosityType.elm create mode 100644 test/PositionDecoder.elm create mode 100644 test/PositionEncoder.elm create mode 100644 test/TimingDecoder.elm create mode 100644 test/TimingEncoder.elm create mode 100644 test/UselessDecoder.elm diff --git a/src/Elm/Common.hs b/src/Elm/Common.hs index b574770..8a5a69f 100644 --- a/src/Elm/Common.hs +++ b/src/Elm/Common.hs @@ -52,3 +52,9 @@ declarations. collectDeclaration :: RenderM Doc -> RenderM () collectDeclaration = mapRWS ((\(defn, (), (imports, _)) -> ((), (), (imports, [pprinter defn])))) + +squarebracks :: Doc -> Doc +squarebracks doc = "[" <+> doc <+> "]" + +pair :: Doc -> Doc -> Doc +pair l r = spaceparens $ l <> comma <+> r diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 8b0acf4..2800aae 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -44,6 +44,56 @@ instance HasDecoder ElmConstructor where dv <- render value return $ "decode" <+> stext name <$$> indent 4 dv + render mc@(MultipleConstructors constrs) = do + cstrs <- mapM renderSum constrs + pure $ constructorName <+> "|> andThen" <+> + spaceparens ("\\x ->" <$$> indent 4 (hsep cstrs) <+> + "fail \"Constructor not matched\"") + where + constructorName :: Doc + constructorName = + if isEnumeration mc then "string" else "field \"tag\" string" + +-- | required "contents" +requiredContents :: Doc +requiredContents = "required" <+> dquotes "contents" + +-- | if x == "" then decode +-- else +renderSumCondition :: T.Text -> Doc -> RenderM Doc +renderSumCondition name contents = + pure $ "if x ==" <+> dquotes (stext name) <+> "then decode" <+> + stext name <+> contents <$$> "else" + +-- | Render a sum type constructor in context of a data type with multiple +-- constructors. +renderSum :: ElmConstructor -> RenderM Doc +renderSum (NamedConstructor name ElmEmpty) = renderSumCondition name mempty +renderSum (NamedConstructor name v@(Values _ _)) = do + (_, val) <- renderConstructorArgs 0 v + renderSumCondition name val +renderSum (NamedConstructor name value) = do + val <- render value + renderSumCondition name $ "|>" <+> requiredContents <+> val +renderSum (RecordConstructor name value) = do + val <- render value + renderSumCondition name val +renderSum (MultipleConstructors constrs) = + hsep <$> mapM renderSum constrs + +-- | Render the decoding of a constructor's arguments. Note the constructor must +-- be from a data type with multiple constructors and that it has multiple +-- constructors itself. +renderConstructorArgs :: Int -> ElmValue -> RenderM (Int, Doc) +renderConstructorArgs i (Values l r) = do + (iL, rndrL) <- renderConstructorArgs i l + (iR, rndrR) <- renderConstructorArgs (iL + 1) r + pure (iR, rndrL <+> rndrR) +renderConstructorArgs i val = do + rndrVal <- render val + let index = parens $ "index" <+> int i <+> rndrVal + pure (i, "|>" <+> requiredContents <+> index) + instance HasDecoder ElmValue where render (ElmRef name) = pure $ "decode" <> stext name render (ElmPrimitiveRef primitive) = renderRef primitive diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs index 16de03b..99f9990 100644 --- a/src/Elm/Encoder.hs +++ b/src/Elm/Encoder.hs @@ -34,10 +34,80 @@ instance HasEncoderRef ElmDatatype where renderRef (ElmPrimitive primitive) = renderRef primitive instance HasEncoder ElmConstructor where + -- Single constructor, no values: empty array + render (NamedConstructor _name ElmEmpty) = + return $ "Json.Encode.list []" + + -- Single constructor, multiple values: create array with values + render (NamedConstructor name value@(Values _ _)) = do + let ps = constructorParameters 0 value + + (dv, _) <- renderVariable ps value + + let cs = stext name <+> foldl1 (<+>) ps <+> "->" + return . nest 4 $ "case x of" <$$> + (nest 4 $ cs <+> "Json.Encode.list" <$$> "[" <+> dv <$$> "]") + + -- Single constructor, one value: skip constructor and render just the value + render (NamedConstructor _name val) = + render val + + render (RecordConstructor _ value) = do dv <- render value return . nest 4 $ "Json.Encode.object" <$$> "[" <+> dv <$$> "]" + render mc@(MultipleConstructors constrs) = do + let rndr = if isEnumeration mc then renderEnumeration else renderSum + dc <- mapM rndr constrs + return . nest 4 $ "case x of" <$$> foldl1 (<$$>) dc + +renderSum :: ElmConstructor -> RenderM Doc +renderSum c@(NamedConstructor name ElmEmpty) = do + dc <- render c + let cs = stext name <+> "->" + let tag = pair (dquotes "tag") ("Json.Encode.string" <+> dquotes (stext name)) + let ct = comma <+> pair (dquotes "contents") dc + return . nest 4 $ cs <+> "Json.Encode.object" <$$> "[" <+> tag <$$> + ct <$$> + "]" + +renderSum (NamedConstructor name value) = do + let ps = constructorParameters 0 value + + (dc, _) <- renderVariable ps value + let dc' = if length ps > 1 then "Json.Encode.list" <+> squarebracks dc else dc + let cs = stext name <+> foldl1 (<+>) ps <+> "->" + let tag = pair (dquotes "tag") ("Json.Encode.string" <+> dquotes (stext name)) + let ct = comma <+> pair (dquotes "contents") dc' + return . nest 4 $ cs <+> "Json.Encode.object" <$$> "[" <+> tag <$$> + ct <$$> + "]" + +renderSum (RecordConstructor name value) = do + dv <- render value + let cs = stext name <+> "->" + let tag = pair (dquotes "tag") (dquotes $ stext name) + let ct = comma <+> dv + return . nest 4 $ cs <+> "Json.Encode.object" <$$> "[" <+> tag <$$> + ct <$$> + "]" + +renderSum (MultipleConstructors constrs) = do + dc <- mapM renderSum constrs + return $ foldl1 (<$$>) dc + + +renderEnumeration :: ElmConstructor -> RenderM Doc +renderEnumeration (NamedConstructor name _) = + return $ stext name <+> "->" <+> + "Json.Encode.string" <+> dquotes (stext name) +renderEnumeration (MultipleConstructors constrs) = do + dc <- mapM renderEnumeration constrs + return $ foldl1 (<$$>) dc +renderEnumeration c = render c + + instance HasEncoder ElmValue where render (ElmField name value) = do fieldModifier <- asks fieldLabelModifier @@ -106,3 +176,35 @@ renderEncoder renderEncoder x = do require "Json.Encode" collectDeclaration . render . toElmType $ x + +-- | Variable names for the members of constructors +-- Used in pattern matches +constructorParameters :: Int -> ElmValue -> [Doc] +constructorParameters _ ElmEmpty = [ empty ] +constructorParameters i (Values l r) = + left ++ right + where + left = constructorParameters i l + right = constructorParameters (length left + i) r +constructorParameters i _ = [ "y" <> int i ] + + +-- | Encode variables following the recipe of an ElmValue +renderVariable :: [Doc] -> ElmValue -> RenderM (Doc, [Doc]) +renderVariable (d : ds) v@(ElmRef {}) = do + v' <- render v + return (v' <+> d, ds) +renderVariable ds ElmEmpty = return (empty, ds) +renderVariable (_ : ds) (ElmPrimitiveRef EUnit) = + return ("Json.Encode.null", ds) +renderVariable (d : ds) (ElmPrimitiveRef ref) = do + r <- renderRef ref + return (r <+> d, ds) +renderVariable ds (Values l r) = do + (left, dsl) <- renderVariable ds l + (right, dsr) <- renderVariable dsl r + return (left <> comma <+> right, dsr) +renderVariable ds f@(ElmField _ _) = do + f' <- render f + return (f', ds) +renderVariable [] _ = error "Amount of variables does not match variables" diff --git a/src/Elm/Record.hs b/src/Elm/Record.hs index 6789531..eb92a42 100644 --- a/src/Elm/Record.hs +++ b/src/Elm/Record.hs @@ -17,6 +17,9 @@ import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) class HasType a where render :: a -> RenderM Doc +class HasRecordType a where + renderRecord :: a -> RenderM Doc + class HasTypeRef a where renderRef :: a -> RenderM Doc @@ -37,7 +40,7 @@ instance HasTypeRef ElmDatatype where instance HasType ElmConstructor where render (RecordConstructor _ value) = do - dv <- render value + dv <- renderRecord value return $ "{" <+> dv <$$> "}" render (NamedConstructor constructorName value) = do dv <- render value @@ -47,17 +50,25 @@ instance HasType ElmConstructor where instance HasType ElmValue where render (ElmRef name) = pure (stext name) - render (ElmPrimitiveRef primitive) = renderRef primitive + render (ElmPrimitiveRef primitive) = elmRefParens primitive <$> renderRef primitive render ElmEmpty = pure (text "") render (Values x y) = do dx <- render x dy <- render y - return $ dx <$$> comma <+> dy + return $ dx <+> dy render (ElmField name value) = do fieldModifier <- asks fieldLabelModifier - dv <- render value + dv <- renderRecord value return $ stext (fieldModifier name) <+> ":" <+> dv +instance HasRecordType ElmValue where + renderRecord (ElmPrimitiveRef primitive) = renderRef primitive + renderRecord (Values x y) = do + dx <- renderRecord x + dy <- renderRecord y + return $ dx <$$> comma <+> dy + renderRecord value = render value + instance HasTypeRef ElmPrimitive where renderRef (EList (ElmPrimitive EChar)) = renderRef EString renderRef (EList datatype) = do @@ -85,6 +96,14 @@ instance HasTypeRef ElmPrimitive where renderRef EUnit = pure "()" renderRef EFloat = pure "Float" +-- | Puts parentheses around the doc of an elm ref if it contains spaces. +elmRefParens :: ElmPrimitive -> Doc -> Doc +elmRefParens (EList (ElmPrimitive EChar)) = id +elmRefParens (EList _) = parens +elmRefParens (EMaybe _) = parens +elmRefParens (EDict _ _) = parens +elmRefParens _ = id + toElmTypeRefWith :: ElmType a => Options -> a -> T.Text diff --git a/src/Elm/Type.hs b/src/Elm/Type.hs index 7c2ea19..3141df2 100644 --- a/src/Elm/Type.hs +++ b/src/Elm/Type.hs @@ -12,7 +12,7 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.IntMap import Data.Map import Data.Proxy -import Data.Text +import Data.Text hiding (all) import Data.Time import GHC.Generics import Prelude @@ -199,3 +199,11 @@ instance ElmType Char where instance ElmType Bool where toElmType _ = ElmPrimitive EBool + +-- | Whether a set of constructors is an enumeration, i.e. whether they lack +-- values. data A = A | B | C would be simple data A = A Int | B | C would not +-- be simple. +isEnumeration :: ElmConstructor -> Bool +isEnumeration (NamedConstructor _ ElmEmpty) = True +isEnumeration (MultipleConstructors cs) = all isEnumeration cs +isEnumeration _ = False diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs index 2561c0b..dd4b2bc 100644 --- a/test/ExportSpec.hs +++ b/test/ExportSpec.hs @@ -55,6 +55,12 @@ data Timing | Stop deriving (Generic, ElmType) +data Monstrosity + = NotSpecial + | OkayIGuess Monstrosity + | Ridiculous Int String [Monstrosity] + deriving (Generic, ElmType) + newtype Useless = Useless () deriving (Generic, ElmType) @@ -120,6 +126,12 @@ toElmTypeSpec = defaultOptions (Proxy :: Proxy Timing) "test/TimingType.elm" + it "toElmTypeSource Monstrosity" $ + shouldMatchTypeSource + (unlines ["module MonstrosityType exposing (..)", "", "", "%s"]) + defaultOptions + (Proxy :: Proxy Monstrosity) + "test/MonstrosityType.elm" it "toElmTypeSource Useless" $ shouldMatchTypeSource (unlines ["module UselessType exposing (..)", "", "", "%s"]) @@ -241,6 +253,51 @@ toElmDecoderSpec = (defaultOptions {fieldLabelModifier = withPrefix "post"}) (Proxy :: Proxy Post) "test/PostDecoderWithOptions.elm" + it "toElmDecoderSource Position" $ + shouldMatchDecoderSource + (unlines + [ "module PositionDecoder exposing (..)" + , "" + , "import Json.Decode exposing (..)" + , "import Json.Decode.Pipeline exposing (..)" + , "import PositionType exposing (..)" + , "" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Position) + "test/PositionDecoder.elm" + it "toElmDecoderSource Timing" $ + shouldMatchDecoderSource + (unlines + [ "module TimingDecoder exposing (..)" + , "" + , "import Json.Decode exposing (..)" + , "import Json.Decode.Pipeline exposing (..)" + , "import TimingType exposing (..)" + , "" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Timing) + "test/TimingDecoder.elm" + it "toElmDecoderSource Monstrosity" $ + shouldMatchDecoderSource + (unlines + [ "module MonstrosityDecoder exposing (..)" + , "" + , "import Json.Decode exposing (..)" + , "import Json.Decode.Pipeline exposing (..)" + , "import MonstrosityType exposing (..)" + , "" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Monstrosity) + "test/MonstrosityDecoder.elm" it "toElmDecoderSourceWithOptions Comment" $ shouldMatchDecoderSource (unlines @@ -258,9 +315,30 @@ toElmDecoderSpec = (defaultOptions {fieldLabelModifier = withPrefix "comment"}) (Proxy :: Proxy Comment) "test/CommentDecoderWithOptions.elm" + it "toElmDecoderSource Useless" $ + shouldMatchDecoderSource + (unlines + [ "module UselessDecoder exposing (..)" + , "" + , "import Json.Decode exposing (..)" + , "import Json.Decode.Pipeline exposing (..)" + , "import UselessType exposing (..)" + , "" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Useless) + "test/UselessDecoder.elm" describe "Convert to Elm decoder references." $ do it "toElmDecoderRef Post" $ toElmDecoderRef (Proxy :: Proxy Post) `shouldBe` "decodePost" + it "toElmDecoderRef Position" $ + toElmDecoderRef (Proxy :: Proxy Position) `shouldBe` "decodePosition" + it "toElmDecoderRef Timing" $ + toElmDecoderRef (Proxy :: Proxy Timing) `shouldBe` "decodeTiming" + it "toElmDecoderRef Monstrosity" $ + toElmDecoderRef (Proxy :: Proxy Monstrosity) `shouldBe` "decodeMonstrosity" it "toElmDecoderRef [Comment]" $ toElmDecoderRef (Proxy :: Proxy [Comment]) `shouldBe` "(list decodeComment)" @@ -342,12 +420,60 @@ toElmEncoderSpec = (defaultOptions {fieldLabelModifier = withPrefix "post"}) (Proxy :: Proxy Post) "test/PostEncoderWithOptions.elm" + it "toElmEncoderSource Position" $ + shouldMatchEncoderSource + (unlines + [ "module PositionEncoder exposing (..)" + , "" + , "import Json.Encode" + , "import PositionType exposing (..)" + , "" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Position) + "test/PositionEncoder.elm" + it "toElmEncoderSourceWithOptions Timing" $ + shouldMatchEncoderSource + (unlines + [ "module TimingEncoder exposing (..)" + , "" + , "import Json.Encode" + , "import TimingType exposing (..)" + , "" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Timing) + "test/TimingEncoder.elm" + it "toElmEncoderSourceWithOptions Monstrosity" $ + shouldMatchEncoderSource + (unlines + [ "module MonstrosityEncoder exposing (..)" + , "" + , "import Json.Encode" + , "import MonstrosityType exposing (..)" + , "" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Monstrosity) + "test/MonstrosityEncoder.elm" describe "Convert to Elm encoder references." $ do it "toElmEncoderRef Post" $ toElmEncoderRef (Proxy :: Proxy Post) `shouldBe` "encodePost" it "toElmEncoderRef [Comment]" $ toElmEncoderRef (Proxy :: Proxy [Comment]) `shouldBe` "(Json.Encode.list << List.map encodeComment)" + it "toElmEncoderRef Position" $ + toElmEncoderRef (Proxy :: Proxy Position) `shouldBe` "encodePosition" + it "toElmEncoderRef Timing" $ + toElmEncoderRef (Proxy :: Proxy Timing) `shouldBe` "encodeTiming" + it "toElmEncoderRef Monstrosity" $ + toElmEncoderRef (Proxy :: Proxy Monstrosity) `shouldBe` "encodeMonstrosity" it "toElmEncoderRef String" $ toElmEncoderRef (Proxy :: Proxy String) `shouldBe` "Json.Encode.string" it "toElmEncoderRef (Maybe String)" $ diff --git a/test/MonstrosityDecoder.elm b/test/MonstrosityDecoder.elm new file mode 100644 index 0000000..0ae9051 --- /dev/null +++ b/test/MonstrosityDecoder.elm @@ -0,0 +1,14 @@ +module MonstrosityDecoder exposing (..) + +import Json.Decode exposing (..) +import Json.Decode.Pipeline exposing (..) +import MonstrosityType exposing (..) + + +decodeMonstrosity : Decoder Monstrosity +decodeMonstrosity = + field "tag" string |> andThen ( \x -> + if x == "NotSpecial" then decode NotSpecial + else if x == "OkayIGuess" then decode OkayIGuess |> required "contents" decodeMonstrosity + else if x == "Ridiculous" then decode Ridiculous |> required "contents" (index 0 int) |> required "contents" (index 1 string) |> required "contents" (index 2 (list decodeMonstrosity)) + else fail "Constructor not matched" ) diff --git a/test/MonstrosityEncoder.elm b/test/MonstrosityEncoder.elm new file mode 100644 index 0000000..76ad390 --- /dev/null +++ b/test/MonstrosityEncoder.elm @@ -0,0 +1,21 @@ +module MonstrosityEncoder exposing (..) + +import Json.Encode +import MonstrosityType exposing (..) + + +encodeMonstrosity : Monstrosity -> Json.Encode.Value +encodeMonstrosity x = + case x of + NotSpecial -> Json.Encode.object + [ ( "tag", Json.Encode.string "NotSpecial" ) + , ( "contents", Json.Encode.list [] ) + ] + OkayIGuess y0 -> Json.Encode.object + [ ( "tag", Json.Encode.string "OkayIGuess" ) + , ( "contents", encodeMonstrosity y0 ) + ] + Ridiculous y0 y1 y2 -> Json.Encode.object + [ ( "tag", Json.Encode.string "Ridiculous" ) + , ( "contents", Json.Encode.list [ Json.Encode.int y0, Json.Encode.string y1, (Json.Encode.list << List.map encodeMonstrosity) y2 ] ) + ] diff --git a/test/MonstrosityType.elm b/test/MonstrosityType.elm new file mode 100644 index 0000000..5a25b98 --- /dev/null +++ b/test/MonstrosityType.elm @@ -0,0 +1,7 @@ +module MonstrosityType exposing (..) + + +type Monstrosity + = NotSpecial + | OkayIGuess Monstrosity + | Ridiculous Int String (List (Monstrosity)) diff --git a/test/PositionDecoder.elm b/test/PositionDecoder.elm new file mode 100644 index 0000000..a4793ed --- /dev/null +++ b/test/PositionDecoder.elm @@ -0,0 +1,14 @@ +module PositionDecoder exposing (..) + +import Json.Decode exposing (..) +import Json.Decode.Pipeline exposing (..) +import PositionType exposing (..) + + +decodePosition : Decoder Position +decodePosition = + string |> andThen ( \x -> + if x == "Beginning" then decode Beginning + else if x == "Middle" then decode Middle + else if x == "End" then decode End + else fail "Constructor not matched" ) diff --git a/test/PositionEncoder.elm b/test/PositionEncoder.elm new file mode 100644 index 0000000..2d0c499 --- /dev/null +++ b/test/PositionEncoder.elm @@ -0,0 +1,12 @@ +module PositionEncoder exposing (..) + +import Json.Encode +import PositionType exposing (..) + + +encodePosition : Position -> Json.Encode.Value +encodePosition x = + case x of + Beginning -> Json.Encode.string "Beginning" + Middle -> Json.Encode.string "Middle" + End -> Json.Encode.string "End" diff --git a/test/TimingDecoder.elm b/test/TimingDecoder.elm new file mode 100644 index 0000000..ab4c49c --- /dev/null +++ b/test/TimingDecoder.elm @@ -0,0 +1,14 @@ +module TimingDecoder exposing (..) + +import Json.Decode exposing (..) +import Json.Decode.Pipeline exposing (..) +import TimingType exposing (..) + + +decodeTiming : Decoder Timing +decodeTiming = + field "tag" string |> andThen ( \x -> + if x == "Start" then decode Start + else if x == "Continue" then decode Continue |> required "contents" float + else if x == "Stop" then decode Stop + else fail "Constructor not matched" ) diff --git a/test/TimingEncoder.elm b/test/TimingEncoder.elm new file mode 100644 index 0000000..934a55f --- /dev/null +++ b/test/TimingEncoder.elm @@ -0,0 +1,21 @@ +module TimingEncoder exposing (..) + +import Json.Encode +import TimingType exposing (..) + + +encodeTiming : Timing -> Json.Encode.Value +encodeTiming x = + case x of + Start -> Json.Encode.object + [ ( "tag", Json.Encode.string "Start" ) + , ( "contents", Json.Encode.list [] ) + ] + Continue y0 -> Json.Encode.object + [ ( "tag", Json.Encode.string "Continue" ) + , ( "contents", Json.Encode.float y0 ) + ] + Stop -> Json.Encode.object + [ ( "tag", Json.Encode.string "Stop" ) + , ( "contents", Json.Encode.list [] ) + ] diff --git a/test/UselessDecoder.elm b/test/UselessDecoder.elm new file mode 100644 index 0000000..965f323 --- /dev/null +++ b/test/UselessDecoder.elm @@ -0,0 +1,11 @@ +module UselessDecoder exposing (..) + +import Json.Decode exposing (..) +import Json.Decode.Pipeline exposing (..) +import UselessType exposing (..) + + +decodeUseless : Decoder Useless +decodeUseless = + decode Useless + (succeed ()) From 5e4971ba6a90abd8d040dbaa77e1c892357a452b Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sat, 11 Mar 2017 11:20:45 +0100 Subject: [PATCH 12/21] Algebraic sum encoders and decoders follow elm-format --- src/Elm/Common.hs | 12 ++++++++++++ src/Elm/Decoder.hs | 25 ++++++++++++++++--------- src/Elm/Encoder.hs | 33 ++++++++++++++++++--------------- test/MonstrosityDecoder.elm | 25 ++++++++++++++++++++----- test/MonstrosityEncoder.elm | 29 +++++++++++++++++------------ test/PositionDecoder.elm | 21 ++++++++++++++++----- test/PositionEncoder.elm | 11 ++++++++--- test/TimingDecoder.elm | 22 +++++++++++++++++----- test/TimingEncoder.elm | 29 +++++++++++++++++------------ 9 files changed, 141 insertions(+), 66 deletions(-) diff --git a/src/Elm/Common.hs b/src/Elm/Common.hs index 8a5a69f..e8ea2e3 100644 --- a/src/Elm/Common.hs +++ b/src/Elm/Common.hs @@ -36,6 +36,18 @@ stext = text . LT.fromStrict spaceparens :: Doc -> Doc spaceparens doc = "(" <+> doc <+> ")" +-- | Parentheses of which the right parenthesis exists on a new line +newlineparens :: Doc -> Doc +newlineparens doc = "(" <> doc <$$> ")" + +-- | An empty line, regardless of current indentation +emptyline :: Doc +emptyline = nest minBound linebreak + +-- | Like <$$>, but with an empty line in between +(<$+$>) :: Doc -> Doc -> Doc +l <$+$> r = l <> emptyline <$$> r + -- type RenderM = RWS Options (Set Text -- The set of required imports , [Text] -- Generated declarations diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 2800aae..a1eff34 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -46,9 +46,16 @@ instance HasDecoder ElmConstructor where render mc@(MultipleConstructors constrs) = do cstrs <- mapM renderSum constrs - pure $ constructorName <+> "|> andThen" <+> - spaceparens ("\\x ->" <$$> indent 4 (hsep cstrs) <+> - "fail \"Constructor not matched\"") + pure $ constructorName <$$> indent 4 + ("|> andThen" <$$> + indent 4 (newlineparens ("\\x ->" <$$> + (indent 4 $ "case x of" <$$> + (indent 4 $ foldl1 (<$+$>) cstrs <$+$> + "_ ->" <$$> indent 4 "fail \"Constructor not matched\"" + ) + ) + )) + ) where constructorName :: Doc constructorName = @@ -58,12 +65,12 @@ instance HasDecoder ElmConstructor where requiredContents :: Doc requiredContents = "required" <+> dquotes "contents" --- | if x == "" then decode --- else +-- | "" -> decode renderSumCondition :: T.Text -> Doc -> RenderM Doc renderSumCondition name contents = - pure $ "if x ==" <+> dquotes (stext name) <+> "then decode" <+> - stext name <+> contents <$$> "else" + pure $ dquotes (stext name) <+> "->" <$$> + indent 4 + ("decode" <+> stext name <$$> indent 4 contents) -- | Render a sum type constructor in context of a data type with multiple -- constructors. @@ -79,7 +86,7 @@ renderSum (RecordConstructor name value) = do val <- render value renderSumCondition name val renderSum (MultipleConstructors constrs) = - hsep <$> mapM renderSum constrs + foldl1 (<$+$>) <$> mapM renderSum constrs -- | Render the decoding of a constructor's arguments. Note the constructor must -- be from a data type with multiple constructors and that it has multiple @@ -88,7 +95,7 @@ renderConstructorArgs :: Int -> ElmValue -> RenderM (Int, Doc) renderConstructorArgs i (Values l r) = do (iL, rndrL) <- renderConstructorArgs i l (iR, rndrR) <- renderConstructorArgs (iL + 1) r - pure (iR, rndrL <+> rndrR) + pure (iR, rndrL <$$> rndrR) renderConstructorArgs i val = do rndrVal <- render val let index = parens $ "index" <+> int i <+> rndrVal diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs index 99f9990..e035843 100644 --- a/src/Elm/Encoder.hs +++ b/src/Elm/Encoder.hs @@ -46,7 +46,7 @@ instance HasEncoder ElmConstructor where let cs = stext name <+> foldl1 (<+>) ps <+> "->" return . nest 4 $ "case x of" <$$> - (nest 4 $ cs <+> "Json.Encode.list" <$$> "[" <+> dv <$$> "]") + (nest 4 $ cs <$$> nest 4 ("Json.Encode.list" <$$> "[" <+> dv <$$> "]")) -- Single constructor, one value: skip constructor and render just the value render (NamedConstructor _name val) = @@ -60,7 +60,14 @@ instance HasEncoder ElmConstructor where render mc@(MultipleConstructors constrs) = do let rndr = if isEnumeration mc then renderEnumeration else renderSum dc <- mapM rndr constrs - return . nest 4 $ "case x of" <$$> foldl1 (<$$>) dc + return . nest 4 $ "case x of" <$$> foldl1 (<$+$>) dc + +jsonEncodeObject :: Doc -> Doc -> Doc -> Doc +jsonEncodeObject constructor tag contents = + nest 4 $ constructor <$$> + nest 4 ("Json.Encode.object" <$$> "[" <+> tag <$$> + contents <$$> + "]") renderSum :: ElmConstructor -> RenderM Doc renderSum c@(NamedConstructor name ElmEmpty) = do @@ -68,9 +75,8 @@ renderSum c@(NamedConstructor name ElmEmpty) = do let cs = stext name <+> "->" let tag = pair (dquotes "tag") ("Json.Encode.string" <+> dquotes (stext name)) let ct = comma <+> pair (dquotes "contents") dc - return . nest 4 $ cs <+> "Json.Encode.object" <$$> "[" <+> tag <$$> - ct <$$> - "]" + + return $ jsonEncodeObject cs tag ct renderSum (NamedConstructor name value) = do let ps = constructorParameters 0 value @@ -80,31 +86,28 @@ renderSum (NamedConstructor name value) = do let cs = stext name <+> foldl1 (<+>) ps <+> "->" let tag = pair (dquotes "tag") ("Json.Encode.string" <+> dquotes (stext name)) let ct = comma <+> pair (dquotes "contents") dc' - return . nest 4 $ cs <+> "Json.Encode.object" <$$> "[" <+> tag <$$> - ct <$$> - "]" + + return $ jsonEncodeObject cs tag ct renderSum (RecordConstructor name value) = do dv <- render value let cs = stext name <+> "->" let tag = pair (dquotes "tag") (dquotes $ stext name) let ct = comma <+> dv - return . nest 4 $ cs <+> "Json.Encode.object" <$$> "[" <+> tag <$$> - ct <$$> - "]" + return $ jsonEncodeObject cs tag ct renderSum (MultipleConstructors constrs) = do dc <- mapM renderSum constrs - return $ foldl1 (<$$>) dc + return $ foldl1 (<$+$>) dc renderEnumeration :: ElmConstructor -> RenderM Doc renderEnumeration (NamedConstructor name _) = - return $ stext name <+> "->" <+> - "Json.Encode.string" <+> dquotes (stext name) + return . nest 4 $ stext name <+> "->" <$$> + "Json.Encode.string" <+> dquotes (stext name) renderEnumeration (MultipleConstructors constrs) = do dc <- mapM renderEnumeration constrs - return $ foldl1 (<$$>) dc + return $ foldl1 (<$+$>) dc renderEnumeration c = render c diff --git a/test/MonstrosityDecoder.elm b/test/MonstrosityDecoder.elm index 0ae9051..8139eaa 100644 --- a/test/MonstrosityDecoder.elm +++ b/test/MonstrosityDecoder.elm @@ -7,8 +7,23 @@ import MonstrosityType exposing (..) decodeMonstrosity : Decoder Monstrosity decodeMonstrosity = - field "tag" string |> andThen ( \x -> - if x == "NotSpecial" then decode NotSpecial - else if x == "OkayIGuess" then decode OkayIGuess |> required "contents" decodeMonstrosity - else if x == "Ridiculous" then decode Ridiculous |> required "contents" (index 0 int) |> required "contents" (index 1 string) |> required "contents" (index 2 (list decodeMonstrosity)) - else fail "Constructor not matched" ) + field "tag" string + |> andThen + (\x -> + case x of + "NotSpecial" -> + decode NotSpecial + + "OkayIGuess" -> + decode OkayIGuess + |> required "contents" decodeMonstrosity + + "Ridiculous" -> + decode Ridiculous + |> required "contents" (index 0 int) + |> required "contents" (index 1 string) + |> required "contents" (index 2 (list decodeMonstrosity)) + + _ -> + fail "Constructor not matched" + ) diff --git a/test/MonstrosityEncoder.elm b/test/MonstrosityEncoder.elm index 76ad390..addb424 100644 --- a/test/MonstrosityEncoder.elm +++ b/test/MonstrosityEncoder.elm @@ -7,15 +7,20 @@ import MonstrosityType exposing (..) encodeMonstrosity : Monstrosity -> Json.Encode.Value encodeMonstrosity x = case x of - NotSpecial -> Json.Encode.object - [ ( "tag", Json.Encode.string "NotSpecial" ) - , ( "contents", Json.Encode.list [] ) - ] - OkayIGuess y0 -> Json.Encode.object - [ ( "tag", Json.Encode.string "OkayIGuess" ) - , ( "contents", encodeMonstrosity y0 ) - ] - Ridiculous y0 y1 y2 -> Json.Encode.object - [ ( "tag", Json.Encode.string "Ridiculous" ) - , ( "contents", Json.Encode.list [ Json.Encode.int y0, Json.Encode.string y1, (Json.Encode.list << List.map encodeMonstrosity) y2 ] ) - ] + NotSpecial -> + Json.Encode.object + [ ( "tag", Json.Encode.string "NotSpecial" ) + , ( "contents", Json.Encode.list [] ) + ] + + OkayIGuess y0 -> + Json.Encode.object + [ ( "tag", Json.Encode.string "OkayIGuess" ) + , ( "contents", encodeMonstrosity y0 ) + ] + + Ridiculous y0 y1 y2 -> + Json.Encode.object + [ ( "tag", Json.Encode.string "Ridiculous" ) + , ( "contents", Json.Encode.list [ Json.Encode.int y0, Json.Encode.string y1, (Json.Encode.list << List.map encodeMonstrosity) y2 ] ) + ] diff --git a/test/PositionDecoder.elm b/test/PositionDecoder.elm index a4793ed..651da91 100644 --- a/test/PositionDecoder.elm +++ b/test/PositionDecoder.elm @@ -7,8 +7,19 @@ import PositionType exposing (..) decodePosition : Decoder Position decodePosition = - string |> andThen ( \x -> - if x == "Beginning" then decode Beginning - else if x == "Middle" then decode Middle - else if x == "End" then decode End - else fail "Constructor not matched" ) + string + |> andThen + (\x -> + case x of + "Beginning" -> + decode Beginning + + "Middle" -> + decode Middle + + "End" -> + decode End + + _ -> + fail "Constructor not matched" + ) diff --git a/test/PositionEncoder.elm b/test/PositionEncoder.elm index 2d0c499..dbca6df 100644 --- a/test/PositionEncoder.elm +++ b/test/PositionEncoder.elm @@ -7,6 +7,11 @@ import PositionType exposing (..) encodePosition : Position -> Json.Encode.Value encodePosition x = case x of - Beginning -> Json.Encode.string "Beginning" - Middle -> Json.Encode.string "Middle" - End -> Json.Encode.string "End" + Beginning -> + Json.Encode.string "Beginning" + + Middle -> + Json.Encode.string "Middle" + + End -> + Json.Encode.string "End" diff --git a/test/TimingDecoder.elm b/test/TimingDecoder.elm index ab4c49c..bef3b72 100644 --- a/test/TimingDecoder.elm +++ b/test/TimingDecoder.elm @@ -7,8 +7,20 @@ import TimingType exposing (..) decodeTiming : Decoder Timing decodeTiming = - field "tag" string |> andThen ( \x -> - if x == "Start" then decode Start - else if x == "Continue" then decode Continue |> required "contents" float - else if x == "Stop" then decode Stop - else fail "Constructor not matched" ) + field "tag" string + |> andThen + (\x -> + case x of + "Start" -> + decode Start + + "Continue" -> + decode Continue + |> required "contents" float + + "Stop" -> + decode Stop + + _ -> + fail "Constructor not matched" + ) diff --git a/test/TimingEncoder.elm b/test/TimingEncoder.elm index 934a55f..d6a1afe 100644 --- a/test/TimingEncoder.elm +++ b/test/TimingEncoder.elm @@ -7,15 +7,20 @@ import TimingType exposing (..) encodeTiming : Timing -> Json.Encode.Value encodeTiming x = case x of - Start -> Json.Encode.object - [ ( "tag", Json.Encode.string "Start" ) - , ( "contents", Json.Encode.list [] ) - ] - Continue y0 -> Json.Encode.object - [ ( "tag", Json.Encode.string "Continue" ) - , ( "contents", Json.Encode.float y0 ) - ] - Stop -> Json.Encode.object - [ ( "tag", Json.Encode.string "Stop" ) - , ( "contents", Json.Encode.list [] ) - ] + Start -> + Json.Encode.object + [ ( "tag", Json.Encode.string "Start" ) + , ( "contents", Json.Encode.list [] ) + ] + + Continue y0 -> + Json.Encode.object + [ ( "tag", Json.Encode.string "Continue" ) + , ( "contents", Json.Encode.float y0 ) + ] + + Stop -> + Json.Encode.object + [ ( "tag", Json.Encode.string "Stop" ) + , ( "contents", Json.Encode.list [] ) + ] From ed8e4e7312042211c8aa62905a6cd649d005ea28 Mon Sep 17 00:00:00 2001 From: Dimitri Sabadie Date: Tue, 20 Jun 2017 15:12:29 +0200 Subject: [PATCH 13/21] Fixed compilation warnings. --- src/Elm/Decoder.hs | 1 + src/Elm/Encoder.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index a1eff34..0fc3b3a 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -112,6 +112,7 @@ instance HasDecoder ElmValue where fieldModifier <- asks fieldLabelModifier dv <- render value return $ "|> required" <+> dquotes (stext (fieldModifier name)) <+> dv + render _ = error "instance HasDecoder ElmValue: should not happen" instance HasDecoderRef ElmPrimitive where renderRef (EList (ElmPrimitive EChar)) = pure "string" diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs index e035843..2b3ceac 100644 --- a/src/Elm/Encoder.hs +++ b/src/Elm/Encoder.hs @@ -124,6 +124,7 @@ instance HasEncoder ElmValue where dx <- render x dy <- render y return $ dx <$$> comma <+> dy + render _ = error "HasEncoderRef ElmValue: should not happen" instance HasEncoderRef ElmPrimitive where renderRef EDate = pure $ parens "Json.Encode.string << toString" From 52d71ace941eaf45ae3d7797af3173e3fa6bc909 Mon Sep 17 00:00:00 2001 From: Erlend Hamberg Date: Sun, 26 Mar 2017 20:36:04 +0200 Subject: [PATCH 14/21] Fix decoder generation for string maps to use `Json.Decode.dict` --- src/Elm/Decoder.hs | 4 ++++ test/CommentDecoder.elm | 2 +- test/CommentDecoderWithOptions.elm | 2 +- test/ExportSpec.hs | 2 +- 4 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 8b0acf4..54035ee 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -61,6 +61,10 @@ instance HasDecoderRef ElmPrimitive where renderRef (EList datatype) = do dt <- renderRef datatype return . parens $ "list" <+> dt + renderRef (EDict EString value) = do + require "Dict" + d <- renderRef value + return . parens $ "dict" <+> d renderRef (EDict key value) = do require "Dict" d <- renderRef (EList (ElmPrimitive (ETuple2 (ElmPrimitive key) value))) diff --git a/test/CommentDecoder.elm b/test/CommentDecoder.elm index 95122b0..d07bd8c 100644 --- a/test/CommentDecoder.elm +++ b/test/CommentDecoder.elm @@ -15,4 +15,4 @@ decodeComment = |> required "mainCategories" (map2 (,) (index 0 string) (index 1 string)) |> required "published" bool |> required "created" decodeDate - |> required "tags" (map Dict.fromList (list (map2 (,) (index 0 string) (index 1 int)))) + |> required "tags" (dict int) diff --git a/test/CommentDecoderWithOptions.elm b/test/CommentDecoderWithOptions.elm index 24419a2..8ff5228 100644 --- a/test/CommentDecoderWithOptions.elm +++ b/test/CommentDecoderWithOptions.elm @@ -15,4 +15,4 @@ decodeComment = |> required "commentMainCategories" (map2 (,) (index 0 string) (index 1 string)) |> required "commentPublished" bool |> required "commentCreated" decodeDate - |> required "commentTags" (map Dict.fromList (list (map2 (,) (index 0 string) (index 1 int)))) + |> required "commentTags" (dict int) diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs index 2561c0b..8d45b45 100644 --- a/test/ExportSpec.hs +++ b/test/ExportSpec.hs @@ -274,7 +274,7 @@ toElmDecoderSpec = "(list (nullable string))" it "toElmDecoderRef (Map String (Maybe String))" $ toElmDecoderRef (Proxy :: Proxy (Map String (Maybe String))) `shouldBe` - "(map Dict.fromList (list (map2 (,) (index 0 string) (index 1 (nullable string)))))" + "(dict (nullable string))" it "toElmDecoderRef (IntMap (Maybe String))" $ toElmDecoderRef (Proxy :: Proxy (IntMap (Maybe String))) `shouldBe` "(map Dict.fromList (list (map2 (,) (index 0 int) (index 1 (nullable string)))))" From a9459c0bbb02efca327b94ee22afafc21bf4bad5 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Sun, 21 May 2017 11:36:15 +0100 Subject: [PATCH 15/21] README tweaks. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 44c043e..3746f71 100644 --- a/README.md +++ b/README.md @@ -80,7 +80,7 @@ stack build stack test --file-watch ``` -### Contributing guide +### Contribution Guide Development happens on the `devel` branch. Pull requests target this branch. From 2c23c6af916eb037945df2423f28eaca5944aad3 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 18 Aug 2017 10:23:41 +0100 Subject: [PATCH 16/21] Updating to LTS-9.1. --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index ada7347..76ded40 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-6.22 +resolver: lts-9.1 # Local packages, usually specified by relative directory name packages: From 589bcadac454d89629bddde86fcb559d1577e702 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 18 Aug 2017 17:52:19 +0100 Subject: [PATCH 17/21] Adding a docstring. --- src/Elm.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Elm.hs b/src/Elm.hs index 0e04e3d..c13a1dd 100644 --- a/src/Elm.hs +++ b/src/Elm.hs @@ -1,3 +1,5 @@ +{-| Generate Elm types, JSON decoders & JSON encoders from Haskell datatypes. +-} module Elm ( module X ) where From cfde636669073bf4124290564dadd456addac0b0 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Sun, 21 May 2017 14:02:23 +0100 Subject: [PATCH 18/21] Switching from a .cabal file to a hpack-format package.yaml. Like all the cool kids are doing these days. :-) --- .gitignore | 1 + elm-export.cabal | 61 ------------------------------------------------ package.yaml | 52 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 61 deletions(-) delete mode 100644 elm-export.cabal create mode 100644 package.yaml diff --git a/.gitignore b/.gitignore index 1c2707e..a2f9a86 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +/elm-export.cabal /.stack-work/ /TAGS /test/elm-package.json diff --git a/elm-export.cabal b/elm-export.cabal deleted file mode 100644 index f6b6ab3..0000000 --- a/elm-export.cabal +++ /dev/null @@ -1,61 +0,0 @@ -name: elm-export -version: 0.6.0.1 -synopsis: A library to generate Elm types from Haskell source. -description: Generate Elm source code automatically from Haskell types. Using GHC.Generics, we can automatically derive Elm type declarations, and Aeson-compatible JSON decoders & encoders. -homepage: http://github.com/krisajenkins/elm-export -stability: alpha -license: OtherLicense -license-file: LICENSE.txt -author: Kris Jenkins -maintainer: kris.jenkins@clearercode.com -copyright: 2015-2017 Kris Jenkins -category: Web -build-type: Simple -extra-source-files: test/*.elm -cabal-version: >=1.10 - -library - hs-source-dirs: src - exposed-modules: Elm - build-depends: base >= 4.7 && < 5 - , bytestring - , containers - , directory - , formatting - , mtl - , text - , time - , wl-pprint-text - default-language: Haskell2010 - ghc-options: -Wall - other-modules: Elm.Type - , Elm.Common - , Elm.Decoder - , Elm.Encoder - , Elm.File - , Elm.Record - -test-suite elm-export-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - other-modules: ExportSpec - , TypesSpec - build-depends: Diff - , HUnit - , QuickCheck - , base - , bytestring - , containers - , elm-export - , hspec - , hspec-core - , quickcheck-instances - , text - , time - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - default-language: Haskell2010 - -source-repository head - type: git - location: https://github.com/krisajenkins/elm-export diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..eb3aeef --- /dev/null +++ b/package.yaml @@ -0,0 +1,52 @@ +name: elm-export +version: '0.6.0.1' +synopsis: A library to generate Elm types from Haskell source. +description: Generate Elm source code automatically from Haskell types. Using GHC.Generics, + we can automatically derive Elm type declarations, and Aeson-compatible JSON decoders + & encoders. +category: Web +author: Kris Jenkins +maintainer: kris.jenkins@clearercode.com +copyright: 2015-2017 Kris Jenkins +license: OtherLicense +license-file: LICENSE.txt +github: krisajenkins/elm-export +homepage: http://github.com/krisajenkins/elm-export +stability: alpha +extra-source-files: +- test/*.elm +dependencies: +- base +- bytestring +- containers +- text +- time +ghc-options: +- -Wall + +library: + source-dirs: src + exposed-modules: + - Elm + dependencies: + - directory + - formatting + - mtl + - wl-pprint-text + +tests: + elm-export-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - Diff + - HUnit + - QuickCheck + - elm-export + - hspec + - hspec-core + - quickcheck-instances From 980c3a5c73ded1f92c627c5f2dbf7e99d993acbe Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 18 Aug 2017 18:03:15 +0100 Subject: [PATCH 19/21] Hlint suggestion: removing redundant brackets. --- src/Elm/Common.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Common.hs b/src/Elm/Common.hs index b574770..bf1615f 100644 --- a/src/Elm/Common.hs +++ b/src/Elm/Common.hs @@ -51,4 +51,4 @@ declarations. -} collectDeclaration :: RenderM Doc -> RenderM () collectDeclaration = - mapRWS ((\(defn, (), (imports, _)) -> ((), (), (imports, [pprinter defn])))) + mapRWS (\(defn, (), (imports, _)) -> ((), (), (imports, [pprinter defn]))) From 7971532914a8503c6382e92a52dd70d95e6704be Mon Sep 17 00:00:00 2001 From: Dimitri Sabadie Date: Fri, 25 Aug 2017 14:37:46 +0200 Subject: [PATCH 20/21] Add more information on an error if it happens. --- src/Elm/Decoder.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index 0fc3b3a..afe31ee 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -112,7 +112,7 @@ instance HasDecoder ElmValue where fieldModifier <- asks fieldLabelModifier dv <- render value return $ "|> required" <+> dquotes (stext (fieldModifier name)) <+> dv - render _ = error "instance HasDecoder ElmValue: should not happen" + render v = error $ "instance HasDecoder ElmValue: should not happen (" ++ show v ++ ")" instance HasDecoderRef ElmPrimitive where renderRef (EList (ElmPrimitive EChar)) = pure "string" From f7ffcc2de542d2eee4c1f81dc325848f2db09e07 Mon Sep 17 00:00:00 2001 From: Dimitri Sabadie Date: Fri, 25 Aug 2017 15:13:57 +0200 Subject: [PATCH 21/21] Complete fix for HasDecoder ElmValue. --- src/Elm/Decoder.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs index afe31ee..01ac785 100644 --- a/src/Elm/Decoder.hs +++ b/src/Elm/Decoder.hs @@ -112,7 +112,7 @@ instance HasDecoder ElmValue where fieldModifier <- asks fieldLabelModifier dv <- render value return $ "|> required" <+> dquotes (stext (fieldModifier name)) <+> dv - render v = error $ "instance HasDecoder ElmValue: should not happen (" ++ show v ++ ")" + render ElmEmpty = pure (stext "") instance HasDecoderRef ElmPrimitive where renderRef (EList (ElmPrimitive EChar)) = pure "string"