From 5138207ce75b0673dd5ab2444dd529014582ff18 Mon Sep 17 00:00:00 2001
From: Dario Oddenino <branch13@gmail.com>
Date: Wed, 3 Oct 2018 10:21:59 +0200
Subject: [PATCH 1/6] tentative code

---
 src/Language/PureScript/Docs/Prim.hs    |  5 ++++
 src/Language/PureScript/Environment.hs  |  1 +
 src/Language/PureScript/Errors.hs       |  2 ++
 src/Language/PureScript/Pretty/Types.hs |  2 +-
 tests/purs/warning/CustomWarning.purs   | 34 +++++++++++++++++++++++--
 5 files changed, 41 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 0116788428..967fca2a97 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -102,6 +102,7 @@ primTypeErrorDocsModule = Module
   , modDeclarations =
       [ warn
       , fail
+      , quoteLabel
       , kindDoc
       , textDoc
       , quoteDoc
@@ -436,6 +437,10 @@ warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
   ]
 
+quoteLabel :: Declaration
+quoteLabel = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines
+  [ "The QuoteLabel type class allows bla bla" ]
+
 kindDoc :: Declaration
 kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines
   [ "`Doc` is the kind of type-level documents."
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index abb25bcaa8..a998adab8e 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -447,6 +447,7 @@ primTypeErrorTypes =
   M.fromList
     [ (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData))
     , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData))
+    , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData))
     , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData))
     , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData))
     , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData))
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index fe351e4078..212540f5b0 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -1409,6 +1409,8 @@ toTypelevelString (TypeApp (TypeConstructor f) x)
   | f == primSubName C.typeError "Text" = toTypelevelString x
 toTypelevelString (TypeApp (TypeConstructor f) x)
   | f == primSubName C.typeError "Quote" = Just (typeAsBox x)
+toTypelevelString (TypeApp (TypeConstructor f) x)
+  | f == primSubName C.typeError "QuoteLabel" = Just (typeAsBox x)
 toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
   | f == primSubName C.typeError "Beside" =
     (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 40c2956eb5..6552d005e3 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -124,7 +124,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
     typeLiterals = mkPattern match where
       match TypeWildcard{} = Just $ text "_"
       match (TypeVar var) = Just $ text $ T.unpack var
-      match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
+      match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintLabel $ Label s
       match (PrettyPrintObject row) = Just $ prettyPrintRowWith tro '{' '}' row
       match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
       match (TUnknown u)
diff --git a/tests/purs/warning/CustomWarning.purs b/tests/purs/warning/CustomWarning.purs
index 7d509ebb20..4f5dc82c62 100644
--- a/tests/purs/warning/CustomWarning.purs
+++ b/tests/purs/warning/CustomWarning.purs
@@ -1,7 +1,37 @@
--- @shouldWarnWith UserDefinedWarning
 module Main where
 
-import Prim.TypeError
+import Prim.TypeError (class Warn, Beside, Quote, QuoteLabel, Text)
+import Prim
+import Type.Row (class RowToList, Cons, Nil)
+
+data Label (l :: Symbol) = Label
+
+baz ::
+  forall row label typ.
+  RowToList row (Cons label typ Nil) =>
+  Warn (Beside (Text "Custom label ") (QuoteLabel label)) =>
+  Record row ->
+  String
+baz _ = ""
+
+-- baz ::
+--   forall l.
+--   Warn (Beside (Text "Missing field ") (QuoteLabel l)) =>
+--   SProxy l ->
+--   String
+-- baz _ = "Hello"
+
+baz' :: String
+baz' = baz { hello: 1 }
+
+baz'' :: String
+baz'' = baz { "hello": 1 }
+
+baz''' :: String
+baz''' = baz { "h e l l o": 1 }
+
+baz'''' :: String
+baz'''' = baz { "hel\"lo": 1 }
 
 foo :: forall t. Warn (Beside (Text "Custom warning ") (Quote t)) => t -> t
 foo x = x

From c682fb452d35b6a89e53ed659c695e2bcccb1797 Mon Sep 17 00:00:00 2001
From: Dario Oddenino <branch13@gmail.com>
Date: Tue, 23 Oct 2018 10:42:53 +0200
Subject: [PATCH 2/6] fixed toTypelevelString, added docs & test

---
 src/Language/PureScript/Docs/Prim.hs    | 13 +++++++---
 src/Language/PureScript/Environment.hs  |  2 +-
 src/Language/PureScript/Errors.hs       |  4 +--
 src/Language/PureScript/Pretty/Types.hs |  2 +-
 tests/purs/warning/CustomWarning.purs   | 34 ++-----------------------
 tests/purs/warning/CustomWarning4.purs  | 31 ++++++++++++++++++++++
 6 files changed, 46 insertions(+), 40 deletions(-)
 create mode 100644 tests/purs/warning/CustomWarning4.purs

diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 967fca2a97..12126590ee 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -437,10 +437,6 @@ warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
   ]
 
-quoteLabel :: Declaration
-quoteLabel = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines
-  [ "The QuoteLabel type class allows bla bla" ]
-
 kindDoc :: Declaration
 kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines
   [ "`Doc` is the kind of type-level documents."
@@ -467,6 +463,15 @@ quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
   ]
 
+quoteLabel :: Declaration
+quoteLabel = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines
+  [ "The QuoteLabel type constructor renders any label as a Doc"
+  , "to be used in a custom type error."
+  , ""
+  , "For more information, see"
+  , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
+  ]
+
 besideDoc :: Declaration
 besideDoc = primTypeOf (P.primSubName "TypeError") "Beside" $ T.unlines
   [ "The Beside type constructor combines two Docs horizontally"
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index a998adab8e..c806470ea3 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -447,9 +447,9 @@ primTypeErrorTypes =
   M.fromList
     [ (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData))
     , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData))
-    , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData))
     , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData))
     , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData))
+    , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData))
     , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData))
     , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData))
     ]
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 212540f5b0..d4807d650b 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -1409,8 +1409,8 @@ toTypelevelString (TypeApp (TypeConstructor f) x)
   | f == primSubName C.typeError "Text" = toTypelevelString x
 toTypelevelString (TypeApp (TypeConstructor f) x)
   | f == primSubName C.typeError "Quote" = Just (typeAsBox x)
-toTypelevelString (TypeApp (TypeConstructor f) x)
-  | f == primSubName C.typeError "QuoteLabel" = Just (typeAsBox x)
+toTypelevelString (TypeApp (TypeConstructor f) (TypeLevelString x))
+  | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x
 toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
   | f == primSubName C.typeError "Beside" =
     (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 6552d005e3..40c2956eb5 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -124,7 +124,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
     typeLiterals = mkPattern match where
       match TypeWildcard{} = Just $ text "_"
       match (TypeVar var) = Just $ text $ T.unpack var
-      match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintLabel $ Label s
+      match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
       match (PrettyPrintObject row) = Just $ prettyPrintRowWith tro '{' '}' row
       match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
       match (TUnknown u)
diff --git a/tests/purs/warning/CustomWarning.purs b/tests/purs/warning/CustomWarning.purs
index 4f5dc82c62..7d509ebb20 100644
--- a/tests/purs/warning/CustomWarning.purs
+++ b/tests/purs/warning/CustomWarning.purs
@@ -1,37 +1,7 @@
+-- @shouldWarnWith UserDefinedWarning
 module Main where
 
-import Prim.TypeError (class Warn, Beside, Quote, QuoteLabel, Text)
-import Prim
-import Type.Row (class RowToList, Cons, Nil)
-
-data Label (l :: Symbol) = Label
-
-baz ::
-  forall row label typ.
-  RowToList row (Cons label typ Nil) =>
-  Warn (Beside (Text "Custom label ") (QuoteLabel label)) =>
-  Record row ->
-  String
-baz _ = ""
-
--- baz ::
---   forall l.
---   Warn (Beside (Text "Missing field ") (QuoteLabel l)) =>
---   SProxy l ->
---   String
--- baz _ = "Hello"
-
-baz' :: String
-baz' = baz { hello: 1 }
-
-baz'' :: String
-baz'' = baz { "hello": 1 }
-
-baz''' :: String
-baz''' = baz { "h e l l o": 1 }
-
-baz'''' :: String
-baz'''' = baz { "hel\"lo": 1 }
+import Prim.TypeError
 
 foo :: forall t. Warn (Beside (Text "Custom warning ") (Quote t)) => t -> t
 foo x = x
diff --git a/tests/purs/warning/CustomWarning4.purs b/tests/purs/warning/CustomWarning4.purs
new file mode 100644
index 0000000000..5ab9de6c40
--- /dev/null
+++ b/tests/purs/warning/CustomWarning4.purs
@@ -0,0 +1,31 @@
+-- @shouldWarnWith UserDefinedWarning
+-- @shouldWarnWith UserDefinedWarning
+-- @shouldWarnWith UserDefinedWarning
+-- @shouldWarnWith UserDefinedWarning
+module Main where
+
+import Prim.TypeError (class Warn, Beside, QuoteLabel, Text)
+import Prim
+import Type.Row (class RowToList, Cons, Nil)
+
+data Label (l :: Symbol) = Label
+
+baz ::
+  forall row label typ.
+  RowToList row (Cons label typ Nil) =>
+  Warn (Beside (Text "Custom label ") (QuoteLabel label)) =>
+  Record row ->
+  String
+baz _ = ""
+
+baz' :: String
+baz' = baz { hello: 1 }
+
+baz'' :: String
+baz'' = baz { "hello": 1 }
+
+baz''' :: String
+baz''' = baz { "h e l l o": 1 }
+
+baz'''' :: String
+baz'''' = baz { "hel\"lo": 1 }

From 9508f682583e74e12d1ecfc265b3992b28cf31a8 Mon Sep 17 00:00:00 2001
From: Dario Oddenino <branch13@gmail.com>
Date: Wed, 24 Oct 2018 09:26:41 +0200
Subject: [PATCH 3/6] doc string updated

---
 src/Language/PureScript/Docs/Prim.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 12126590ee..24824a26f4 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -102,10 +102,10 @@ primTypeErrorDocsModule = Module
   , modDeclarations =
       [ warn
       , fail
-      , quoteLabel
       , kindDoc
       , textDoc
       , quoteDoc
+      , quoteLabelDoc
       , besideDoc
       , aboveDoc
       ]
@@ -463,10 +463,10 @@ quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
   ]
 
-quoteLabel :: Declaration
-quoteLabel = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines
-  [ "The QuoteLabel type constructor renders any label as a Doc"
-  , "to be used in a custom type error."
+quoteLabelDoc :: Declaration
+quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines
+  [ "The QuoteLabel type constructor renders any Symbol as a syntactically valid label,"
+  , "escaping with quotes as needed."
   , ""
   , "For more information, see"
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

From d69c642a973c34ace5368e863d0af5dec595687b Mon Sep 17 00:00:00 2001
From: Dario Oddenino <branch13@gmail.com>
Date: Tue, 30 Oct 2018 10:28:00 +0100
Subject: [PATCH 4/6] doc string fix

---
 src/Language/PureScript/Docs/Prim.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 24824a26f4..51c02fe277 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -465,8 +465,8 @@ quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines
 
 quoteLabelDoc :: Declaration
 quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines
-  [ "The QuoteLabel type constructor renders any Symbol as a syntactically valid label,"
-  , "escaping with quotes as needed."
+  [ "The `QuoteLabel` type constructor will produce a `Doc` when given a `Symbol`. When the resulting `Doc` is rendered "
+  , "for a `Warn` or `Fail` constraint, a syntactically valid label will be produces, escaping with quotes as needed."
   , ""
   , "For more information, see"
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

From b27fc163364e10894f907f36d35d4eb35a07a8c3 Mon Sep 17 00:00:00 2001
From: Dario Oddenino <branch13@gmail.com>
Date: Tue, 30 Oct 2018 11:03:42 +0100
Subject: [PATCH 5/6] doc string typo fix

---
 src/Language/PureScript/Docs/Prim.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 51c02fe277..78ebac77ea 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -465,8 +465,8 @@ quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines
 
 quoteLabelDoc :: Declaration
 quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines
-  [ "The `QuoteLabel` type constructor will produce a `Doc` when given a `Symbol`. When the resulting `Doc` is rendered "
-  , "for a `Warn` or `Fail` constraint, a syntactically valid label will be produces, escaping with quotes as needed."
+  [ "The `QuoteLabel` type constructor will produce a `Doc` when given a `Symbol`. When the resulting `Doc` is rendered"
+  , "for a `Warn` or `Fail` constraint, a syntactically valid label will be produced, escaping with quotes as needed."
   , ""
   , "For more information, see"
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

From 557c7aea41cd1cebd18370ab2bf04caba34b55aa Mon Sep 17 00:00:00 2001
From: Dario Oddenino <branch13@gmail.com>
Date: Tue, 30 Oct 2018 11:47:24 +0100
Subject: [PATCH 6/6] added quotelabel to kindDoc and contributors file

---
 CONTRIBUTORS.md                      | 1 +
 src/Language/PureScript/Docs/Prim.hs | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 78a5abc8ee..fdc523bdae 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -126,6 +126,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license](http://opensource.org/licenses/MIT) |
 | [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license](http://opensource.org/licenses/MIT) |
 | [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) |
+| [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) |
 
 ### Contributors using Modified Terms
 
diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 78ebac77ea..a6ee336193 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -442,7 +442,7 @@ kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines
   [ "`Doc` is the kind of type-level documents."
   , ""
   , "This kind is used with the `Fail` and `Warn` type clases."
-  , "Build up a `Doc` with `Text`, `Quote`, `Beside`, and `Above`."
+  , "Build up a `Doc` with `Text`, `Quote`, `QuoteLabel`, `Beside`, and `Above`."
   ]
 
 textDoc :: Declaration