Implements support for algebraic sum types

README.md

@@ -62,6 +62,7 @@ The decoders we produce require these extra Elm packages installed:
 ``` sh
 elm package install NoRedInk/elm-decode-pipeline
 elm package install krisajenkins/elm-exts
+elm-package install justinmimbs/elm-date-extra
 ```
 
 ## Development

elm-export.cabal

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

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
@@ -52,3 +64,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

src/Elm/Decoder.hs

@@ -44,6 +44,63 @@ 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 <$$> 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>" -> decode <name>
+renderSumCondition :: T.Text -> Doc -> RenderM Doc
+renderSumCondition name contents =
+  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.
+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
   render (ElmPrimitiveRef primitive) = renderRef primitive
@@ -55,6 +112,7 @@ 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"

src/Elm/Encoder.hs

@@ -34,10 +34,83 @@ 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 <$$> nest 4 ("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
+
+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
+  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 $ jsonEncodeObject cs 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 $ 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 $ jsonEncodeObject cs tag ct
+
+renderSum (MultipleConstructors constrs) = do
+  dc <- mapM renderSum constrs
+  return $ foldl1 (<$+$>) dc
+
+
+renderEnumeration :: ElmConstructor -> RenderM Doc
+renderEnumeration (NamedConstructor name _) =
+  return . nest 4 $ 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
@@ -51,9 +124,10 @@ 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"
+  renderRef EDate = pure $ parens "Json.Encode.string << toUtcIsoString"
   renderRef EUnit = pure "Json.Encode.null"
   renderRef EInt = pure "Json.Encode.int"
   renderRef EChar = pure "Json.Encode.char"
@@ -106,3 +180,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"

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

src/Elm/Type.hs

@@ -10,11 +10,13 @@ module Elm.Type where
 
 import Data.Int (Int16, Int32, Int64, Int8)
 import Data.IntMap
+import Data.List.NonEmpty (NonEmpty)
 import Data.Map
 import Data.Proxy
-import Data.Text
+import Data.Text hiding (all)
 import Data.Time
 import GHC.Generics
+import Numeric.Natural (Natural)
 import Prelude
 
 data ElmDatatype
@@ -128,6 +130,10 @@ instance ElmType a =>
          ElmType [a] where
   toElmType _ = ElmPrimitive (EList (toElmType (Proxy :: Proxy a)))
 
+instance ElmType a =>
+         ElmType (NonEmpty a) where
+  toElmType _ = toElmType (Proxy :: Proxy [a])
+
 instance ElmType a =>
          ElmType (Maybe a) where
   toElmType _ = ElmPrimitive (EMaybe (toElmType (Proxy :: Proxy a)))
@@ -162,6 +168,9 @@ instance ElmType Int32 where
 instance ElmType Int64 where
   toElmType _ = ElmPrimitive EInt
 
+instance ElmType Natural where
+  toElmType _ = ElmPrimitive EInt
+
 instance (ElmType a, ElmType b) =>
          ElmType (a, b) where
   toElmType _ =
@@ -199,3 +208,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