Merge pull request #227 from nellaG/default-tag-for-union

Optional default tag for union type

CHANGES.md

@@ -6,6 +6,14 @@ Version 0.4.0
 
 To be released.
 
+### Language
+
+ -  Union tags became possible to have `default` keyword.  It's useful
+    for migrating a record type to a union type.  [[#13], [#227]]
+
+[#13]: https://github.com/spoqa/nirum/issues/13
+[#227]: https://github.com/spoqa/nirum/pull/227
+
 
 Version 0.3.0
 -------------
@@ -102,7 +110,7 @@ Released on February 18, 2018.
 
 ### Et cetera
 
- -  The officialy distributed executable binaries for Linux became
+ -  The officially distributed executable binaries for Linux became
     independent from [glibc]; instead statically linked to [musl].  [#216]
  -  The Docker image now has `nirum` command in `PATH`.  [[#155]]
  -  The Docker image became based and built on [Alpine Linux][] so that

docs/refactoring.md

@@ -203,3 +203,73 @@ its lack of order if necessary.
 When a JSON array serialized from a list field is deserialized to a set,
 the same values shown more than once are collapsed to unique values.
 Also, its order is not preserved.
+
+
+Interchangeability of union type and record type
+------------------------------------------------
+
+Sometimes we need to evolve an existing record type to be extended.
+
+But when we change a record type to a union type, it breaks backward
+compatibility.  Suppose we have a record type named `name` that looks like:
+
+~~~~~~~~ nirum
+record name (text fullname);
+~~~~~~~~
+
+An example of JSON serialized one would look like:
+
+~~~~~~~~ json
+{
+    "_type": "name",
+    "fullname": "John Doe"
+}
+~~~~~~~~
+
+What if we need to be more sensible to culture-specific names?  Now we decide
+to change it to a union:
+
+~~~~~~~~ nirum
+union name
+    = wastern-name (text first-name, text? middle-name, text last-name)
+    | east-asian-name (text family-name, text given-name)
+    | culture-agnostice-name (text fullname)
+    ;
+~~~~~~~~
+
+Since union types requires `"_tag"` field besides `"_type"` field when
+they are deserialized, data sent from the older programs becomes to break
+compatibility.
+
+In order to make union types possible to deserialize existing record data
+(which lacks `"_tag"` field), we need to choose `default` tag for data lacking
+`"_tag"` field:
+
+~~~~~~~~ nirum
+union name
+    = wastern-name (text first-name, text? middle-name, text last-name)
+    | east-asian-name (text family-name, text given-name)
+    | default culture-agnostice-name (text fullname)
+    ;
+~~~~~~~~
+
+With a `default` tag, union types become possible to deserialize data lacking
+`"_tag"` field, and they are treated as an instance of the `default` tag.
+For example, where we have a payload data like:
+
+~~~~~~~~ json
+{
+    "_type": "name",
+    "fullname": "John Doe"
+}
+~~~~~~~~
+
+It's treated as equivalent to the following one:
+
+~~~~~~~~ json
+{
+    "_type": "name",
+    "_tag": "culture_agnostic_name",
+    "fullname": "John Doe"
+}
+~~~~~~~~

examples/shapes.nrm

@@ -32,7 +32,7 @@ record point (
 union shape
     # Type constructors in a sum type become translated to subtypes in OO
     # languages, and datatypes in functional languages.
-    = rectangle (
+    = default rectangle (
           # Each tag can have zero or more fields like record types.
           point upper-left,
           point lower-right

src/Nirum/Constructs/DeclarationSet.hs

@@ -3,6 +3,7 @@ module Nirum.Constructs.DeclarationSet ( DeclarationSet ()
                                        , NameDuplication ( BehindNameDuplication
                                                          , FacialNameDuplication
                                                          )
+                                       , delete
                                        , empty
                                        , fromList
                                        , lookup
@@ -15,6 +16,7 @@ module Nirum.Constructs.DeclarationSet ( DeclarationSet ()
                                        , (!)
                                        ) where
 
+import qualified Data.List as List
 import Data.Maybe (fromJust)
 import qualified GHC.Exts as L
 import Prelude hiding (lookup, null)
@@ -97,6 +99,19 @@ union :: Declaration a
       -> Either NameDuplication (DeclarationSet a)
 union a b = fromList $ toList a ++ toList b
 
+delete :: Declaration a
+       => a
+       -> DeclarationSet a
+       -> DeclarationSet a
+delete d DeclarationSet { declarations = ds, index = ix } =
+    DeclarationSet
+        { declarations = M.delete identifier ds
+        , index = List.delete identifier ix
+        }
+  where
+    identifier :: Identifier
+    identifier = facialName $ name d
+
 instance (Declaration a) => L.IsList (DeclarationSet a) where
     type Item (DeclarationSet a) = a
     fromList declarations' =

src/Nirum/Constructs/Identifier.hs

@@ -61,6 +61,7 @@ reservedKeywords = [ "enum"
                    , "type"
                    , "unboxed"
                    , "union"
+                   , "default"
                    ]
 
 identifierRule :: Parser Identifier

src/Nirum/Constructs/TypeDeclaration.hs

@@ -34,12 +34,12 @@ module Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)
                                                , UnboxedType
                                                , UnionType
                                                , canonicalType
+                                               , defaultTag
                                                , fields
                                                , innerType
                                                , jsonType
                                                , members
                                                , primitiveTypeIdentifier
-                                               , tags
                                                )
                                         , TypeDeclaration ( Import
                                                           , ServiceDeclaration
@@ -53,9 +53,11 @@ module Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)
                                                           , typeAnnotations
                                                           , typename
                                                           )
+                                        , unionType
+                                        , tags
                                         ) where
 
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, maybeToList)
 import Data.String (IsString (fromString))
 
 import qualified Data.Text as T
@@ -66,7 +68,7 @@ import Nirum.Constructs.Declaration ( Declaration (annotations, name)
                                     , Documented (docs)
                                     )
 import Nirum.Constructs.Docs (Docs (Docs), toCodeWithPrefix)
-import Nirum.Constructs.DeclarationSet (DeclarationSet, null', toList)
+import Nirum.Constructs.DeclarationSet as DS
 import Nirum.Constructs.Identifier (Identifier)
 import Nirum.Constructs.ModulePath (ModulePath)
 import Nirum.Constructs.Name (Name (Name))
@@ -81,12 +83,22 @@ data Type
     | UnboxedType { innerType :: TypeExpression }
     | EnumType { members :: DeclarationSet EnumMember }
     | RecordType { fields :: DeclarationSet Field }
-    | UnionType { tags :: DeclarationSet Tag }
+    | UnionType -- | Use 'unionType' instaed.
+        { nondefaultTags :: DeclarationSet Tag -- This should not be exported.
+        , defaultTag :: Maybe Tag
+        }
     | PrimitiveType { primitiveTypeIdentifier :: PrimitiveTypeIdentifier
                     , jsonType :: JsonType
                     }
     deriving (Eq, Ord, Show)
 
+tags :: Type -> DeclarationSet Tag
+tags UnionType { nondefaultTags = tags', defaultTag = defTag } =
+    case fromList $ toList tags' ++ maybeToList defTag of
+        Right ts -> ts
+        Left _ -> DS.empty -- must never happen!
+tags _ = DS.empty
+
 -- | Member of 'EnumType'.
 data EnumMember = EnumMember Name AnnotationSet deriving (Eq, Ord, Show)
 
@@ -131,6 +143,15 @@ data Tag = Tag { tagName :: Name
                , tagAnnotations :: AnnotationSet
                } deriving (Eq, Ord, Show)
 
+-- | Create a 'UnionType'.
+unionType :: [Tag] -> Maybe Tag -> Either NameDuplication Type
+unionType t dt = case fromList t of
+                     Right ts -> Right $
+                         case dt of
+                             Nothing -> UnionType ts Nothing
+                             Just dt' -> UnionType (delete dt' ts) dt
+                     Left a -> Left a
+
 instance Construct Tag where
     toCode tag@(Tag name' fields' _) =
         if null' fields'
@@ -204,10 +225,10 @@ instance Construct TypeDeclaration where
       where
         fieldsCode = T.intercalate "\n" $ map toCode $ toList fields'
         docs' = A.lookupDocs annotationSet'
-    toCode (TypeDeclaration name' (UnionType tags') annotationSet') =
-        T.concat [ toCode annotationSet'
+    toCode (TypeDeclaration name' (UnionType tags' defaultTag') as') =
+        T.concat [ toCode as'
                  , "union ", nameCode
-                 , toCodeWithPrefix "\n    " (A.lookupDocs annotationSet')
+                 , toCodeWithPrefix "\n    " (A.lookupDocs as')
                  , "\n    = " , tagsCode
                  , "\n    ;"
                  ]
@@ -216,17 +237,20 @@ instance Construct TypeDeclaration where
         nameCode = toCode name'
         tagsCode :: T.Text
         tagsCode = T.intercalate "\n    | "
-                                 [ T.replace "\n" "\n    " (toCode t)
-                                 | t <- toList tags'
+                                 [ T.replace "\n" "\n    " $
+                                             if defaultTag' == Just t
+                                             then T.append "default " (toCode t)
+                                             else toCode t
+                                 | t <- maybeToList defaultTag' ++ toList tags'
                                  ]
     toCode (TypeDeclaration name'
                             (PrimitiveType typename' jsonType')
-                            annotationSet') =
-        T.concat [ toCode annotationSet'
+                            as') =
+        T.concat [ toCode as'
                  , "// primitive type `", toCode name', "`\n"
                  , "//     internal type identifier: ", showT typename', "\n"
                  , "//     coded to json ", showT jsonType', " type\n"
-                 , docString (A.lookupDocs annotationSet')
+                 , docString (A.lookupDocs as')
                  ]
       where
         showT :: Show a => a -> T.Text