Fix formatting of T.Some (#2608)

Fixes #2601

According to the standard the `Some` needs to be escaped when used as
a field accessor because the `any-label` grammar rule kicks in, which
specifically does not permit `Some`.

Author: Gabriella439

dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs

@@ -7,6 +7,7 @@ import Dhall.Context                 (Context, empty, insert, toList)
 import Dhall.LSP.Backend.Diagnostics (Position, positionToOffset)
 import Dhall.LSP.Backend.Parsing     (holeExpr)
 import Dhall.Parser                  (Src, exprFromText)
+import Dhall.Pretty                  (UnescapedLabel(..))
 import Dhall.TypeCheck               (typeOf, typeWithA)
 import System.Directory              (doesDirectoryExist, listDirectory)
 import System.Environment            (getEnvironment)
@@ -186,9 +187,9 @@ completeProjections (CompletionContext context values) expr =
   -- complete a union constructor by inspecting the union value
   completeUnion _A (Union m) =
     let constructor (k, Nothing) =
-            Completion (Dhall.Pretty.escapeLabel True k) (Just _A)
+            Completion (Dhall.Pretty.escapeLabel AnyLabelOrSome k) (Just _A)
         constructor (k, Just v) =
-            Completion (Dhall.Pretty.escapeLabel True k) (Just (Pi mempty k v _A))
+            Completion (Dhall.Pretty.escapeLabel AnyLabelOrSome k) (Just (Pi mempty k v _A))
      in map constructor (Dhall.Map.toList m)
   completeUnion _ _ = []
 
@@ -197,5 +198,5 @@ completeProjections (CompletionContext context values) expr =
   completeRecord (Record m) = map toCompletion (Dhall.Map.toList $ recordFieldValue <$> m)
     where
       toCompletion (name, typ) =
-          Completion (Dhall.Pretty.escapeLabel True name) (Just typ)
+          Completion (Dhall.Pretty.escapeLabel AnyLabel name) (Just typ)
   completeRecord _ = []

dhall/src/Dhall/Pretty.hs

@@ -15,6 +15,7 @@ module Dhall.Pretty
     , Dhall.Pretty.Internal.layoutOpts
 
     , escapeEnvironmentVariable
+    , UnescapedLabel(..)
     , escapeLabel
 
     , temporalToText

dhall/src/Dhall/Pretty/Internal.hs

@@ -31,6 +31,7 @@ module Dhall.Pretty.Internal (
     , prettyEnvironmentVariable
 
     , prettyConst
+    , UnescapedLabel(..)
     , escapeLabel
     , prettyLabel
     , prettyAnyLabel
@@ -518,26 +519,44 @@ headCharacter c = alpha c || c == '_'
 tailCharacter :: Char -> Bool
 tailCharacter c = alphaNum c || c == '_' || c == '-' || c == '/'
 
+-- | The set of labels which do not need to be escaped
+data UnescapedLabel
+    = NonReservedLabel
+    -- ^ This corresponds to the `nonreserved-label` rule in the grammar
+    | AnyLabel
+    -- ^ This corresponds to the `any-label` rule in the grammar
+    | AnyLabelOrSome
+    -- ^ This corresponds to the `any-label-or-some` rule in the grammar
+
 -- | Escape a label if it is not valid when unquoted
-escapeLabel :: Bool -> Text -> Text
-escapeLabel allowReserved l =
+escapeLabel :: UnescapedLabel -> Text -> Text
+escapeLabel allowedLabel l =
     case Text.uncons l of
         Just (h, t)
-            | headCharacter h && Text.all tailCharacter t && (notReservedIdentifier || (allowReserved && someOrNotLanguageKeyword)) && l /= "?"
+            | headCharacter h && Text.all tailCharacter t && allowed && l /= "?"
                 -> l
         _       -> "`" <> l <> "`"
-    where
-        notReservedIdentifier = not (Data.HashSet.member l reservedIdentifiers)
-        someOrNotLanguageKeyword = l == "Some" || not (Data.HashSet.member l reservedKeywords)
+  where
+    allowed = case allowedLabel of
+        NonReservedLabel -> notReservedIdentifier
+        AnyLabel         -> notReservedKeyword
+        AnyLabelOrSome   -> notReservedKeyword || l == "Some"
+
+    notReservedIdentifier = not (Data.HashSet.member l reservedIdentifiers)
 
-prettyLabelShared :: Bool -> Text -> Doc Ann
+    notReservedKeyword = not (Data.HashSet.member l reservedKeywords)
+
+prettyLabelShared :: UnescapedLabel -> Text -> Doc Ann
 prettyLabelShared b l = label (Pretty.pretty (escapeLabel b l))
 
 prettyLabel :: Text -> Doc Ann
-prettyLabel = prettyLabelShared False
+prettyLabel = prettyLabelShared NonReservedLabel
 
 prettyAnyLabel :: Text -> Doc Ann
-prettyAnyLabel = prettyLabelShared True
+prettyAnyLabel = prettyLabelShared AnyLabel
+
+prettyAnyLabelOrSome :: Text -> Doc Ann
+prettyAnyLabelOrSome = prettyLabelShared AnyLabelOrSome
 
 prettyKeys
     :: Foldable list
@@ -571,7 +590,7 @@ prettyKeys prettyK keys = Pretty.group (Pretty.flatAlt long short)
 prettyLabels :: [Text] -> Doc Ann
 prettyLabels a
     | null a    = lbrace <> rbrace
-    | otherwise = braces (map (duplicate . prettyAnyLabel) a)
+    | otherwise = braces (map (duplicate . prettyAnyLabelOrSome) a)
 
 prettyNumber :: Integer -> Doc Ann
 prettyNumber = literal . Pretty.pretty
@@ -846,7 +865,7 @@ prettyPrinters characterSet =
             prettyKeyValue prettyKey prettyOperatorExpression equals
                 (makeKeyValue b c)
 
-        prettyKey (WithLabel text) = prettyAnyLabel text
+        prettyKey (WithLabel text) = prettyAnyLabelOrSome text
         prettyKey  WithQuestion    = syntax "?"
     prettyExpression (Assert a) =
         Pretty.group (Pretty.flatAlt long short)
@@ -1558,7 +1577,7 @@ prettyPrinters characterSet =
     prettyRecord :: Pretty a => Map Text (RecordField Src a) -> Doc Ann
     prettyRecord =
         ( braces
-        . map (prettyKeyValue prettyAnyLabel prettyExpression colon . adapt)
+        . map (prettyKeyValue prettyAnyLabelOrSome prettyExpression colon . adapt)
         . Map.toList
         )
       where
@@ -1615,14 +1634,14 @@ prettyPrinters characterSet =
                     | Var (V key' 0) <- Dhall.Syntax.shallowDenote val
                     , key == key'
                     , not (containsComment mSrc2) ->
-                        duplicate (prettyKeys prettyAnyLabel [(mSrc0, key, mSrc1)])
+                        duplicate (prettyKeys prettyAnyLabelOrSome [(mSrc0, key, mSrc1)])
                 _ ->
-                    prettyKeyValue prettyAnyLabel prettyExpression equals kv
+                    prettyKeyValue prettyAnyLabelOrSome prettyExpression equals kv
 
     prettyAlternative (key, Just val) =
-        prettyKeyValue prettyAnyLabel prettyExpression colon (makeKeyValue (pure key) val)
+        prettyKeyValue prettyAnyLabelOrSome prettyExpression colon (makeKeyValue (pure key) val)
     prettyAlternative (key, Nothing) =
-        duplicate (prettyAnyLabel key)
+        duplicate (prettyAnyLabelOrSome key)
 
     prettyUnion :: Pretty a => Map Text (Maybe (Expr Src a)) -> Doc Ann
     prettyUnion =

dhall/src/Dhall/TypeCheck.hs

@@ -47,7 +47,7 @@ import Dhall.Eval
     , Val (..)
     , (~>)
     )
-import Dhall.Pretty                      (Ann)
+import Dhall.Pretty                      (Ann, UnescapedLabel(..))
 import Dhall.Src                         (Src)
 import Lens.Family                       (over)
 import Prettyprinter                     (Doc, Pretty (..), vsep)
@@ -2915,7 +2915,7 @@ prettyTypeMessage (InvalidDuplicateField k expr0 expr1) =
         \                                                                                \n\
         \... which is not a record type                                                  \n"
       where
-        txt0 = insert (Dhall.Pretty.Internal.escapeLabel True k)
+        txt0 = insert (Dhall.Pretty.Internal.escapeLabel AnyLabelOrSome k)
         txt1 = insert expr0
         txt2 = insert expr1
 
@@ -3073,7 +3073,7 @@ prettyTypeMessage (DuplicateFieldCannotBeMerged ks) = ErrorMessages {..}
         \                                                                                \n\
         \" <> txt1 <> "\n"
       where
-        txt0 = insert (Dhall.Pretty.Internal.escapeLabel True (NonEmpty.head ks))
+        txt0 = insert (Dhall.Pretty.Internal.escapeLabel AnyLabelOrSome (NonEmpty.head ks))
 
         txt1 = insert (toPath ks)
 
@@ -5055,7 +5055,7 @@ checkContext context =
 toPath :: (Functor list, Foldable list) => list Text -> Text
 toPath ks =
     Text.intercalate "."
-        (Foldable.toList (fmap (Dhall.Pretty.Internal.escapeLabel True) ks))
+        (Foldable.toList (fmap (Dhall.Pretty.Internal.escapeLabel AnyLabelOrSome) ks))
 
 duplicateElement :: Ord a => [a] -> Maybe a
 duplicateElement = go Data.Set.empty

dhall/tests/format/issue2601A.dhall

@@ -0,0 +1,11 @@
+let T = < Some | Type >
+
+let t
+    : T
+    = T.`Some`
+
+let x
+    : T
+    = T.Type
+
+in  True

dhall/tests/format/issue2601B.dhall

@@ -0,0 +1,11 @@
+let T = < Some | Type >
+
+let t
+    : T
+    = T.`Some`
+
+let x
+    : T
+    = T.Type
+
+in  True

nix/packages/lsp-test.nix

@@ -0,0 +1,27 @@
+{ mkDerivation, aeson, aeson-pretty, ansi-terminal, async, base
+, bytestring, co-log-core, conduit, conduit-parse, containers
+, data-default, Diff, directory, exceptions, extra, filepath, Glob
+, hspec, lens, lib, lsp, lsp-types, mtl, parser-combinators
+, process, row-types, some, text, time, transformers, unix
+, unliftio
+}:
+mkDerivation {
+  pname = "lsp-test";
+  version = "0.15.0.1";
+  sha256 = "ad5be9baa344337b87958dfeb765e3edceca47c4ada57fb1ffeccf4056c57ad8";
+  libraryHaskellDepends = [
+    aeson aeson-pretty ansi-terminal async base bytestring co-log-core
+    conduit conduit-parse containers data-default Diff directory
+    exceptions filepath Glob lens lsp lsp-types mtl parser-combinators
+    process row-types some text time transformers unix
+  ];
+  testHaskellDepends = [
+    aeson base co-log-core containers data-default directory filepath
+    hspec lens lsp mtl parser-combinators process text unliftio
+  ];
+  testToolDepends = [ lsp ];
+  benchmarkHaskellDepends = [ base extra lsp process ];
+  homepage = "https://github.com/haskell/lsp/blob/master/lsp-test/README.md";
+  description = "Functional test framework for LSP servers";
+  license = lib.licenses.bsd3;
+}