Implement new showConstructor keyword

dhall/src/Dhall/Eval.hs

@@ -228,6 +228,7 @@ data Val a
     | VPrefer !(Val a) !(Val a)
     | VMerge !(Val a) !(Val a) !(Maybe (Val a))
     | VToMap !(Val a) !(Maybe (Val a))
+    | VShowConstructor !(Val a)
     | VField !(Val a) !Text
     | VInject !(Map Text (Maybe (Val a))) !Text !(Maybe (Val a))
     | VProject !(Val a) !(Either (Set Text) (Val a))
@@ -807,6 +808,14 @@ eval !env t0 =
                     in  VListLit Nothing s
                 (x', ma') ->
                     VToMap x' ma'
+        ShowConstructor x ->
+            case eval env x of
+                VInject m k _
+                    | Just _ <- Map.lookup k m -> VTextLit (VChunks [] k)
+                    | otherwise                -> error errorMsg
+                VSome _ -> VTextLit (VChunks [] "Some")
+                VNone _ -> VTextLit (VChunks [] "None")
+                x' -> VShowConstructor x'
         Field t (Syntax.fieldSelectionLabel -> k) ->
             vField (eval env t) k
         Project t (Left ks) ->
@@ -1243,6 +1252,8 @@ quote !env !t0 =
             Merge (quote env t) (quote env u) (fmap (quote env) ma)
         VToMap t ma ->
             ToMap (quote env t) (fmap (quote env) ma)
+        VShowConstructor t ->
+            ShowConstructor (quote env t)
         VField t k ->
             Field (quote env t) $ Syntax.makeFieldSelection k
         VProject t p ->
@@ -1442,6 +1453,8 @@ alphaNormalize = goEnv EmptyNames
                 Merge (go x) (go y) (fmap go ma)
             ToMap x ma ->
                 ToMap (go x) (fmap go ma)
+            ShowConstructor x ->
+                ShowConstructor (go x)
             Field t k ->
                 Field (go t) k
             Project t ks ->

dhall/src/Dhall/Normalize.hs

@@ -623,6 +623,14 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                 return (ListLit listType keyValues)
             _ ->
                 return (ToMap x' t')
+    ShowConstructor x -> do
+        x' <- loop x
+        return $ case x' of
+            Field (Union ktsY) (Syntax.fieldSelectionLabel -> kY) ->
+                case Dhall.Map.lookup kY ktsY of
+                    Just _ -> TextLit (Chunks [] kY)
+                    _ -> ShowConstructor x'
+            _ -> ShowConstructor x'
     Field r k@FieldSelection{fieldSelectionLabel = x}        -> do
         let singletonRecordLit v = RecordLit (Dhall.Map.singleton x v)
 
@@ -909,6 +917,9 @@ isNormalized e0 = loop (Syntax.denote e0)
       ToMap x t -> case x of
           RecordLit _ -> False
           _ -> loop x && all loop t
+      ShowConstructor x -> loop x && case x of
+          Field (Union _) _ -> False
+          _ -> True
       Field r (FieldSelection Nothing k Nothing) -> case r of
           RecordLit _ -> False
           Project _ _ -> False

dhall/src/Dhall/Parser/Expression.hs

@@ -520,10 +520,15 @@ parsers embedded = Parsers{..}
 
                     return (\a -> ToMap a Nothing, Just "argument to ❰toMap❱")
 
-            let alternative3 =
+            let alternative3 = do
+                    try (_showConstructor *> nonemptyWhitespace)
+
+                    return (\a -> ShowConstructor a, Just "argument to ❰showConstructor❱")
+
+            let alternative4 =
                     return (id, Nothing)
 
-            (f, maybeMessage) <- alternative0 <|> alternative1 <|> alternative2 <|> alternative3
+            (f, maybeMessage) <- alternative0 <|> alternative1 <|> alternative2 <|> alternative3 <|> alternative4
 
             let adapt parser =
                     case maybeMessage of

dhall/src/Dhall/Parser/Token.hs

@@ -47,6 +47,7 @@ module Dhall.Parser.Token (
     _using,
     _merge,
     _toMap,
+    _showConstructor,
     _assert,
     _Some,
     _None,
@@ -952,6 +953,13 @@ _merge = keyword "merge"
 _toMap :: Parser ()
 _toMap = keyword "toMap"
 
+{-| Parse the @showConstructor@ keyword
+
+    This corresponds to the @showConstructor@ rule from the official grammar
+-}
+_showConstructor :: Parser ()
+_showConstructor = keyword "showConstructor"
+
 {-| Parse the @assert@ keyword
 
     This corresponds to the @assert@ rule from the official grammar

dhall/src/Dhall/Syntax.hs

@@ -632,6 +632,8 @@ data Expr s a
     -- | > ToMap x (Just t)                         ~  toMap x : t
     --   > ToMap x  Nothing                         ~  toMap x
     | ToMap (Expr s a) (Maybe (Expr s a))
+    -- | > ShowConstructor x                        ~  showConstructor x
+    | ShowConstructor (Expr s a)
     -- | > Field e (FieldSelection _ x _)              ~  e.x
     | Field (Expr s a) (FieldSelection s)
     -- | > Project e (Left xs)                      ~  e.{ xs }
@@ -879,6 +881,7 @@ unsafeSubExpressions f (Prefer cs a b c) = Prefer cs <$> a' <*> f b <*> f c
 unsafeSubExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b
 unsafeSubExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t
 unsafeSubExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t
+unsafeSubExpressions f (ShowConstructor a) = ShowConstructor <$> f a
 unsafeSubExpressions f (Project a b) = Project <$> f a <*> traverse f b
 unsafeSubExpressions f (Assert a) = Assert <$> f a
 unsafeSubExpressions f (Equivalent cs a b) = Equivalent cs <$> f a <*> f b

dhall/src/Dhall/TypeCheck.hs

@@ -1130,6 +1130,14 @@ infer typer = loop
 
                        die (MapTypeMismatch (quote names (mapType _T')) _T₁'')
 
+        ShowConstructor e -> do
+            _E' <- loop ctx e
+            case _E' of
+              VUnion _ -> pure VText
+              VOptional _ -> pure VText
+
+              _ -> die ShowConstructorNotOnUnion
+
         Field e (Syntax.fieldSelectionLabel -> x) -> do
             _E' <- loop ctx e
 
@@ -1396,6 +1404,7 @@ data TypeMessage s a
     | CantListAppend (Expr s a) (Expr s a)
     | CantAdd (Expr s a) (Expr s a)
     | CantMultiply (Expr s a) (Expr s a)
+    | ShowConstructorNotOnUnion
     deriving (Show)
 
 formatHints :: [Doc Ann] -> Doc Ann
@@ -4550,6 +4559,12 @@ prettyTypeMessage (CantAdd expr0 expr1) =
 prettyTypeMessage (CantMultiply expr0 expr1) =
         buildNaturalOperator "*" expr0 expr1
 
+prettyTypeMessage ShowConstructorNotOnUnion = ErrorMessages {..}
+  where
+      short = "ShowConstructorNotOnUnion"
+      hints = []
+      long = ""
+
 buildBooleanOperator :: Pretty a => Text -> Expr s a -> Expr s a -> ErrorMessages
 buildBooleanOperator operator expr0 expr1 = ErrorMessages {..}
   where
@@ -4831,6 +4846,8 @@ messageExpressions f m = case m of
         CantAdd <$> f a <*> f b
     CantMultiply a b ->
         CantMultiply <$> f a <*> f b
+    ShowConstructorNotOnUnion ->
+        pure ShowConstructorNotOnUnion
 
 {-| Newtype used to wrap error messages so that they render with a more
     detailed explanation of what went wrong

dhall/tests/Dhall/Test/QuickCheck.hs

@@ -1,3 +1,5 @@
+-- TODO: update because we added ShowConstructor constructor to Expr in Dhall.Syntax
+
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE FlexibleInstances   #-}