Skip to content

Commit a13c656

Browse files
Gabriella439darichey
Gabriella439
and
darichey
authored
Add showConstructor keyword (#2384)
… as standardized in dhall-lang/dhall-lang#1257 Co-authored-by: David Richey <darichey1@gmail.com>
1 parent 19f3c5c commit a13c656

File tree

13 files changed

+125
-3
lines changed

13 files changed

+125
-3
lines changed

‎dhall-bash/src/Dhall/Bash.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -340,6 +340,7 @@ dhallToStatement expr0 var0 = go (Dhall.Core.normalize expr0)
340340
go e@(RecordCompletion {}) = Left (UnsupportedStatement e)
341341
go e@(Merge {}) = Left (UnsupportedStatement e)
342342
go e@(ToMap {}) = Left (UnsupportedStatement e)
343+
go e@(ShowConstructor {}) = Left (UnsupportedStatement e)
343344
go e@(Field {}) = Left (UnsupportedStatement e)
344345
go e@(Project {}) = Left (UnsupportedStatement e)
345346
go e@(Assert {}) = Left (UnsupportedStatement e)

‎dhall-json/src/Dhall/JSON.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1045,6 +1045,11 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
10451045
a' = loop a
10461046
b' = fmap loop b
10471047

1048+
Core.ShowConstructor a ->
1049+
Core.ShowConstructor a'
1050+
where
1051+
a' = loop a
1052+
10481053
Core.Field a b ->
10491054
Core.Field a' b
10501055
where

‎dhall-nix/src/Dhall/Nix.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -142,6 +142,8 @@ data CompileError
142142
-- ^ Nix does not provide a way to reference a shadowed variable
143143
| CannotProjectByType
144144
-- ^ We currently do not support threading around type information
145+
| CannotShowConstructor
146+
-- ^ We currently do not support the `showConstructor` keyword
145147
deriving (Typeable)
146148

147149
instance Show CompileError where
@@ -205,6 +207,16 @@ The ❰dhall-to-nix❱ compiler does not support projecting out a subset of a re
205207
by the expected type (i.e. ❰someRecord.(someType)❱
206208
|]
207209

210+
show CannotShowConstructor =
211+
Data.Text.unpack [NeatInterpolation.text|
212+
$_ERROR: Cannot translate the ❰showConstructor❱ keyword
213+
214+
The ❰dhall-to-nix❱ compiler does not support the ❰showConstructor❱ keyword.
215+
216+
In theory this keyword shouldn't need to be translated anyway since the keyword
217+
doesn't survive β-normalization, so if you see this error message there might be
218+
an internal error in ❰dhall-to-nix❱ that you should report.
219+
|]
208220

209221
_ERROR :: Data.Text.Text
210222
_ERROR = "\ESC[1;31mError\ESC[0m"
@@ -614,6 +626,8 @@ dhallToNix e =
614626
let map_ = Fix (NBinary NApp "map" (Fix (NAbs "k" (Fix (NSet NNonRecursive setBindings)))))
615627
let toMap = Fix (NAbs "kvs" (Fix (NBinary NApp map_ ks)))
616628
return (Fix (NBinary NApp toMap a'))
629+
loop (ShowConstructor _) = do
630+
Left CannotShowConstructor
617631
loop (Prefer _ _ b c) = do
618632
b' <- loop b
619633
c' <- loop c

‎dhall/src/Dhall/Binary.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -638,6 +638,9 @@ decodeExpressionInternal decodeEmbed = go
638638
let minutes = sign (_HH * 60 + _MM)
639639

640640
return (TimeZoneLiteral (Time.TimeZone minutes False ""))
641+
34 -> do
642+
t <- go
643+
return (ShowConstructor t)
641644
_ ->
642645
die ("Unexpected tag: " <> show tag)
643646

@@ -1060,6 +1063,11 @@ encodeExpressionInternal encodeEmbed = go
10601063

10611064
(_HH, _MM) = abs minutes `divMod` 60
10621065

1066+
ShowConstructor t ->
1067+
encodeList2
1068+
(Encoding.encodeInt 34)
1069+
(go t)
1070+
10631071
Note _ b ->
10641072
go b
10651073

‎dhall/src/Dhall/Diff.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -636,6 +636,10 @@ skeleton (ToMap {}) =
636636
keyword "toMap"
637637
<> " "
638638
<> ignore
639+
skeleton (ShowConstructor {}) =
640+
keyword "showConstructor"
641+
<> " "
642+
<> ignore
639643
skeleton (Field {}) =
640644
ignore
641645
<> dot
@@ -783,6 +787,15 @@ diffAnnotatedExpression l@(ToMap {}) r =
783787
mismatch l r
784788
diffAnnotatedExpression l r@(ToMap {}) =
785789
mismatch l r
790+
diffAnnotatedExpression (ShowConstructor aL) (ShowConstructor aR) = align doc
791+
where
792+
doc = keyword "showConstructor"
793+
<> " "
794+
<> format " " (diffWithExpression aL aR)
795+
diffAnnotatedExpression l@(ShowConstructor {}) r =
796+
mismatch l r
797+
diffAnnotatedExpression l r@(ShowConstructor {}) =
798+
mismatch l r
786799
diffAnnotatedExpression (ListLit aL@(Just _) bL) (ListLit aR bR) = align doc
787800
where
788801
doc = format " " (diffList bL bR)

‎dhall/src/Dhall/Eval.hs

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -228,6 +228,7 @@ data Val a
228228
| VPrefer !(Val a) !(Val a)
229229
| VMerge !(Val a) !(Val a) !(Maybe (Val a))
230230
| VToMap !(Val a) !(Maybe (Val a))
231+
| VShowConstructor !(Val a)
231232
| VField !(Val a) !Text
232233
| VInject !(Map Text (Maybe (Val a))) !Text !(Maybe (Val a))
233234
| VProject !(Val a) !(Either (Set Text) (Val a))
@@ -807,6 +808,14 @@ eval !env t0 =
807808
in VListLit Nothing s
808809
(x', ma') ->
809810
VToMap x' ma'
811+
ShowConstructor x ->
812+
case eval env x of
813+
VInject m k _
814+
| Just _ <- Map.lookup k m -> VTextLit (VChunks [] k)
815+
| otherwise -> error errorMsg
816+
VSome _ -> VTextLit (VChunks [] "Some")
817+
VNone _ -> VTextLit (VChunks [] "None")
818+
x' -> VShowConstructor x'
810819
Field t (Syntax.fieldSelectionLabel -> k) ->
811820
vField (eval env t) k
812821
Project t (Left ks) ->
@@ -1033,6 +1042,8 @@ conv !env t0 t0' =
10331042
conv env t t' && conv env u u'
10341043
(VToMap t _, VToMap t' _) ->
10351044
conv env t t'
1045+
(VShowConstructor t, VShowConstructor t') ->
1046+
conv env t t'
10361047
(VField t k, VField t' k') ->
10371048
conv env t t' && k == k'
10381049
(VProject t (Left ks), VProject t' (Left ks')) ->
@@ -1243,6 +1254,8 @@ quote !env !t0 =
12431254
Merge (quote env t) (quote env u) (fmap (quote env) ma)
12441255
VToMap t ma ->
12451256
ToMap (quote env t) (fmap (quote env) ma)
1257+
VShowConstructor t ->
1258+
ShowConstructor (quote env t)
12461259
VField t k ->
12471260
Field (quote env t) $ Syntax.makeFieldSelection k
12481261
VProject t p ->
@@ -1442,6 +1455,8 @@ alphaNormalize = goEnv EmptyNames
14421455
Merge (go x) (go y) (fmap go ma)
14431456
ToMap x ma ->
14441457
ToMap (go x) (fmap go ma)
1458+
ShowConstructor x ->
1459+
ShowConstructor (go x)
14451460
Field t k ->
14461461
Field (go t) k
14471462
Project t ks ->

‎dhall/src/Dhall/Normalize.hs

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -623,6 +623,18 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
623623
return (ListLit listType keyValues)
624624
_ ->
625625
return (ToMap x' t')
626+
ShowConstructor x -> do
627+
x' <- loop x
628+
return $ case x' of
629+
Field (Union ktsY) (Syntax.fieldSelectionLabel -> kY) ->
630+
case Dhall.Map.lookup kY ktsY of
631+
Just _ -> TextLit (Chunks [] kY)
632+
_ -> ShowConstructor x'
633+
Some _ ->
634+
TextLit (Chunks [] "Some")
635+
App None _ ->
636+
TextLit (Chunks [] "None")
637+
_ -> ShowConstructor x'
626638
Field r k@FieldSelection{fieldSelectionLabel = x} -> do
627639
let singletonRecordLit v = RecordLit (Dhall.Map.singleton x v)
628640

@@ -909,6 +921,11 @@ isNormalized e0 = loop (Syntax.denote e0)
909921
ToMap x t -> case x of
910922
RecordLit _ -> False
911923
_ -> loop x && all loop t
924+
ShowConstructor x -> loop x && case x of
925+
Field (Union _) _ -> False
926+
Some _ -> False
927+
App None _ -> False
928+
_ -> True
912929
Field r (FieldSelection Nothing k Nothing) -> case r of
913930
RecordLit _ -> False
914931
Project _ _ -> False

‎dhall/src/Dhall/Parser/Expression.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -520,10 +520,15 @@ parsers embedded = Parsers{..}
520520

521521
return (\a -> ToMap a Nothing, Just "argument to ❰toMap❱")
522522

523-
let alternative3 =
523+
let alternative3 = do
524+
try (_showConstructor *> nonemptyWhitespace)
525+
526+
return (\a -> ShowConstructor a, Just "argument to ❰showConstructor❱")
527+
528+
let alternative4 =
524529
return (id, Nothing)
525530

526-
(f, maybeMessage) <- alternative0 <|> alternative1 <|> alternative2 <|> alternative3
531+
(f, maybeMessage) <- alternative0 <|> alternative1 <|> alternative2 <|> alternative3 <|> alternative4
527532

528533
let adapt parser =
529534
case maybeMessage of

‎dhall/src/Dhall/Parser/Token.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ module Dhall.Parser.Token (
4747
_using,
4848
_merge,
4949
_toMap,
50+
_showConstructor,
5051
_assert,
5152
_Some,
5253
_None,
@@ -952,6 +953,13 @@ _merge = keyword "merge"
952953
_toMap :: Parser ()
953954
_toMap = keyword "toMap"
954955

956+
{-| Parse the @showConstructor@ keyword
957+
958+
This corresponds to the @showConstructor@ rule from the official grammar
959+
-}
960+
_showConstructor :: Parser ()
961+
_showConstructor = keyword "showConstructor"
962+
955963
{-| Parse the @assert@ keyword
956964
957965
This corresponds to the @assert@ rule from the official grammar

‎dhall/src/Dhall/Pretty/Internal.hs

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1199,6 +1199,7 @@ prettyPrinters characterSet =
11991199
Some a -> app (builtin "Some") (a : args)
12001200
Merge a b Nothing -> app (keyword "merge") (a : b : args)
12011201
ToMap a Nothing -> app (keyword "toMap") (a : args)
1202+
ShowConstructor a -> app (keyword "showConstructor") (a : args)
12021203
e | Note _ b <- e ->
12031204
go args b
12041205
| null args ->
@@ -1480,7 +1481,19 @@ prettyPrinters characterSet =
14801481
<> keyword "toMap"
14811482
<> case shallowDenote val' of
14821483
RecordCompletion _T r ->
1483-
completion _T r
1484+
" "
1485+
<> completion _T r
1486+
_ -> Pretty.hardline
1487+
<> " "
1488+
<> prettyImportExpression_ val'
1489+
1490+
ShowConstructor val' ->
1491+
" "
1492+
<> keyword "showConstructor"
1493+
<> case shallowDenote val' of
1494+
RecordCompletion _T r ->
1495+
" "
1496+
<> completion _T r
14841497
_ -> Pretty.hardline
14851498
<> " "
14861499
<> prettyImportExpression_ val'

‎dhall/src/Dhall/Syntax.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -632,6 +632,8 @@ data Expr s a
632632
-- | > ToMap x (Just t) ~ toMap x : t
633633
-- > ToMap x Nothing ~ toMap x
634634
| ToMap (Expr s a) (Maybe (Expr s a))
635+
-- | > ShowConstructor x ~ showConstructor x
636+
| ShowConstructor (Expr s a)
635637
-- | > Field e (FieldSelection _ x _) ~ e.x
636638
| Field (Expr s a) (FieldSelection s)
637639
-- | > Project e (Left xs) ~ e.{ xs }
@@ -879,6 +881,7 @@ unsafeSubExpressions f (Prefer cs a b c) = Prefer cs <$> a' <*> f b <*> f c
879881
unsafeSubExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b
880882
unsafeSubExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t
881883
unsafeSubExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t
884+
unsafeSubExpressions f (ShowConstructor a) = ShowConstructor <$> f a
882885
unsafeSubExpressions f (Project a b) = Project <$> f a <*> traverse f b
883886
unsafeSubExpressions f (Assert a) = Assert <$> f a
884887
unsafeSubExpressions f (Equivalent cs a b) = Equivalent cs <$> f a <*> f b

‎dhall/src/Dhall/TypeCheck.hs

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1130,6 +1130,14 @@ infer typer = loop
11301130

11311131
die (MapTypeMismatch (quote names (mapType _T')) _T₁'')
11321132

1133+
ShowConstructor e -> do
1134+
_E' <- loop ctx e
1135+
case _E' of
1136+
VUnion _ -> pure VText
1137+
VOptional _ -> pure VText
1138+
1139+
_ -> die ShowConstructorNotOnUnion
1140+
11331141
Field e (Syntax.fieldSelectionLabel -> x) -> do
11341142
_E' <- loop ctx e
11351143

@@ -1396,6 +1404,7 @@ data TypeMessage s a
13961404
| CantListAppend (Expr s a) (Expr s a)
13971405
| CantAdd (Expr s a) (Expr s a)
13981406
| CantMultiply (Expr s a) (Expr s a)
1407+
| ShowConstructorNotOnUnion
13991408
deriving (Show)
14001409

14011410
formatHints :: [Doc Ann] -> Doc Ann
@@ -4550,6 +4559,12 @@ prettyTypeMessage (CantAdd expr0 expr1) =
45504559
prettyTypeMessage (CantMultiply expr0 expr1) =
45514560
buildNaturalOperator "*" expr0 expr1
45524561

4562+
prettyTypeMessage ShowConstructorNotOnUnion = ErrorMessages {..}
4563+
where
4564+
short = "ShowConstructorNotOnUnion"
4565+
hints = []
4566+
long = ""
4567+
45534568
buildBooleanOperator :: Pretty a => Text -> Expr s a -> Expr s a -> ErrorMessages
45544569
buildBooleanOperator operator expr0 expr1 = ErrorMessages {..}
45554570
where
@@ -4831,6 +4846,8 @@ messageExpressions f m = case m of
48314846
CantAdd <$> f a <*> f b
48324847
CantMultiply a b ->
48334848
CantMultiply <$> f a <*> f b
4849+
ShowConstructorNotOnUnion ->
4850+
pure ShowConstructorNotOnUnion
48344851

48354852
{-| Newtype used to wrap error messages so that they render with a more
48364853
detailed explanation of what went wrong

‎dhall/tests/Dhall/Test/QuickCheck.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
-- TODO: update because we added ShowConstructor constructor to Expr in Dhall.Syntax
2+
13
{-# LANGUAGE CPP #-}
24
{-# LANGUAGE DataKinds #-}
35
{-# LANGUAGE FlexibleInstances #-}
@@ -405,6 +407,7 @@ instance (Arbitrary s, Arbitrary a) => Arbitrary (Expr s a) where
405407
% (7 :: W "RecordCompletion")
406408
% (1 :: W "Merge")
407409
% (1 :: W "ToMap")
410+
% (1 :: W "ShowConstructor")
408411
% (7 :: W "Field")
409412
% (7 :: W "Project")
410413
% (1 :: W "Assert")

0 commit comments

Comments
 (0)