Elm 0.19

README.md

@@ -42,13 +42,11 @@ 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
+    require "Date exposing (Date)"
+    renderType (Proxy :: Proxy Person)
+    renderDecoder (Proxy :: Proxy Person)
+    renderEncoder (Proxy :: Proxy Person)
 
 main :: IO ()
 main = specsToDir [spec] "some/where/output"
@@ -57,18 +55,14 @@ 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:
 
-``` sh
-elm package install NoRedInk/elm-decode-pipeline
+```sh
+elm package install NoRedInk/elm-json-decode-pipeline
 elm package install krisajenkins/elm-exts
+elm package install rtfeldman/elm-iso8601-date-strings
 ```
 
 ## Development
@@ -87,8 +81,28 @@ 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
+Updated to Elm 0.18.
+
+### V0.5.x
+???
+
+### V0.4.x
+???
+
 ### V0.3.0.0
 * Renamed `ToElmType` to `ElmType`, for brevity.
 
@@ -100,8 +114,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

elm-export.cabal

@@ -23,6 +23,7 @@ library
                      , directory
                      , formatting
                      , mtl
+                     , semigroups
                      , text
                      , time
                      , wl-pprint-text

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

src/Elm/Common.hs

@@ -2,11 +2,13 @@
 
 module Elm.Common where
 
+import Control.Monad.RWS
+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.Monoid
-import           Data.Text  (Text)
-import           qualified Data.Text.Lazy as LT
-import           Formatting hiding (text)
 
 data Options = Options
   { fieldLabelModifier :: Text -> Text
@@ -33,3 +35,38 @@ 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
+                            ) ()
+
+{-| 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 =
+  mapRWS ((\(defn, (), (imports, _)) -> ((), (), (imports, [pprinter defn]))))
+
+squarebracks :: Doc -> Doc
+squarebracks doc = "[" <+> doc <+> "]"
+
+pair :: Doc -> Doc -> Doc
+pair l r = spaceparens $ l <> comma <+> r

src/Elm/Decoder.hs

@@ -8,20 +8,20 @@ module Elm.Decoder
   , toElmDecoderRefWith
   , toElmDecoderSource
   , toElmDecoderSourceWith
+  , renderDecoder
   ) where
 
-import Control.Monad.Reader
-import Data.Monoid
+import Control.Monad.RWS
 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
@@ -39,10 +39,67 @@ instance HasDecoderRef ElmDatatype where
 instance HasDecoder ElmConstructor where
   render (NamedConstructor name value) = do
     dv <- render value
-    return $ "decode" <+> stext name <$$> indent 4 dv
+    return $ "Json.Decode.succeed" <+> stext name <$$> indent 4 dv
   render (RecordConstructor name value) = do
     dv <- render value
-    return $ "decode" <+> stext name <$$> indent 4 dv
+    return $ "Json.Decode.succeed" <+> stext name <$$> indent 4 dv
+
+  render mc@(MultipleConstructors constrs) = do
+      cstrs <- mapM renderSum constrs
+      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 =
+        if isEnumeration mc then "string" else "field \"tag\" string"
+
+-- | required "contents"
+requiredContents :: Doc
+requiredContents = "required" <+> dquotes "contents"
+
+-- | "<name>" -> Json.Decode.succeed <name>
+renderSumCondition :: T.Text -> Doc -> RenderM Doc
+renderSumCondition name contents =
+  pure $ dquotes (stext name) <+> "->" <$$>
+    indent 4
+      ("Json.Decode.succeed" <+> stext name <$$> indent 4 contents)
+
+-- | 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) =
+  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
+-- 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
@@ -55,25 +112,29 @@ instance HasDecoder ElmValue where
     fieldModifier <- asks fieldLabelModifier
     dv <- render value
     return $ "|> required" <+> dquotes (stext (fieldModifier name)) <+> dv
+  render ElmEmpty = pure (stext "")
 
 instance HasDecoderRef ElmPrimitive where
   renderRef (EList (ElmPrimitive EChar)) = pure "string"
   renderRef (EList datatype) = do
     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
     dt <- renderRef datatype
-    return . parens $ "maybe" <+> dt
+    return . parens $ "nullable" <+> dt
   renderRef (ETuple2 x y) = do
     dx <- renderRef x
     dy <- renderRef y
     return . parens $
       "map2 (,)" <+> parens ("index 0" <+> dx) <+> parens ("index 1" <+> dy)
   renderRef EUnit = pure $ parens "succeed ()"
-  renderRef EDate = pure "decodeDate"
+  renderRef EDate = do
+    require "Iso8601"
+    pure "Iso8601.decoder"
   renderRef EInt = pure "int"
   renderRef EBool = pure "bool"
   renderRef EChar = pure "char"
@@ -83,7 +144,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 $ evalRWS (renderRef (toElmType x)) options ()
 
 toElmDecoderRef
   :: ElmType a
@@ -93,9 +155,18 @@ toElmDecoderRef = toElmDecoderRefWith defaultOptions
 toElmDecoderSourceWith
   :: ElmType a
   => Options -> a -> T.Text
-toElmDecoderSourceWith options x = pprinter $ runReader (render (toElmType x)) options
+toElmDecoderSourceWith options x =
+  pprinter . fst $ evalRWS (render (toElmType x)) options ()
 
 toElmDecoderSource
   :: ElmType a
   => a -> T.Text
 toElmDecoderSource = toElmDecoderSourceWith defaultOptions
+
+renderDecoder
+  :: ElmType a
+  => a -> RenderM ()
+renderDecoder x = do
+  require "Json.Decode exposing (..)"
+  require "Json.Decode.Pipeline exposing (..)"
+  collectDeclaration . render . toElmType $ x