Implement OverloadedLabels

See
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels
for the big picture.

Reviewers: goldfire, simonpj, austin, hvr, bgamari

Reviewed By: simonpj, bgamari

Subscribers: kosmikus, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1331

17 files changed, 213 insertions, 1 deletions

diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index f345ce6b1f..f76dc34354 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -32,7 +32,8 @@ check title expected got
 expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
-                             "AlternativeLayoutRuleTransitional"]
+                             "AlternativeLayoutRuleTransitional",
+                             "OverloadedLabels"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T
index f114c0fdfa..c67d42f1a8 100644
--- a/testsuite/tests/overloadedrecflds/ghci/all.T
+++ b/testsuite/tests/overloadedrecflds/ghci/all.T
@@ -1 +1,2 @@
 test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
+test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script'])
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script
new file mode 100644
index 0000000000..3b5dde1800
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script
@@ -0,0 +1,12 @@
+:set -XOverloadedLabels
+:t #x
+:m + GHC.OverloadedLabels
+:seti -XFlexibleInstances -XFlexibleContexts -XTypeFamilies -XMultiParamTypeClasses
+instance IsLabel x [Char] where fromLabel _ = "hello"
+instance (s ~ [Char], t ~ [Char]) => IsLabel x (s -> t) where fromLabel _ = (++ " world")
+#x :: String
+#x #y
+:{
+#x
+"goodbye"
+:}
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout
new file mode 100644
index 0000000000..08a34c0bdd
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout
@@ -0,0 +1,4 @@
+#x :: IsLabel "x" t => t
+"hello"
+"hello world"
+"goodbye world"
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 5ff61e2735..a9c7426c78 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -22,3 +22,4 @@ test('overloadedrecfldsfail12',
      multimod_compile_fail, ['overloadedrecfldsfail12', ''])
 test('overloadedrecfldsfail13', normal, compile_fail, [''])
 test('overloadedrecfldsfail14', normal, compile_fail, [''])
+test('overloadedlabelsfail01', normal, compile_fail, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs
new file mode 100644
index 0000000000..361da45086
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-}
+
+import GHC.OverloadedLabels
+
+-- No instance for (OverloadedLabel "x" t0)
+a = #x
+
+-- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0)
+b = #x #y
+
+-- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t)
+c :: IsLabel "x" t => t
+c = #y
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
new file mode 100644
index 0000000000..1631c6de6d
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
@@ -0,0 +1,31 @@
+
+overloadedlabelsfail01.hs:6:5: error:
+    No instance for (IsLabel "x" t2)
+      arising from the overloaded label ‘#x’
+    In the expression: #x
+    In an equation for ‘a’: a = #x
+
+overloadedlabelsfail01.hs:9:5: error:
+    No instance for (IsLabel "x" (t0 -> t1))
+      arising from the overloaded label ‘#x’
+      (maybe you haven't applied a function to enough arguments?)
+    In the expression: #x
+    In the expression: #x #y
+    In an equation for ‘b’: b = #x #y
+
+overloadedlabelsfail01.hs:9:8: error:
+    No instance for (IsLabel "y" t0)
+      arising from the overloaded label ‘#y’
+    In the first argument of ‘#x’, namely ‘#y’
+    In the expression: #x #y
+    In an equation for ‘b’: b = #x #y
+
+overloadedlabelsfail01.hs:13:5: error:
+    Could not deduce (IsLabel "y" t)
+      arising from the overloaded label ‘#y’
+    from the context: IsLabel "x" t
+      bound by the type signature for:
+                 c :: IsLabel "x" t => t
+      at overloadedlabelsfail01.hs:12:6-23
+    In the expression: #y
+    In an equation for ‘c’: c = #y
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs
new file mode 100644
index 0000000000..e3b38c245e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}
+module OverloadedLabelsRun04_A where
+
+import GHC.OverloadedLabels
+import Language.Haskell.TH
+
+instance IsLabel x (Q [Dec]) where
+  fromLabel _ = [d| main = putStrLn "Ok" |]
diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
index 3d7cef2c54..21391ac646 100644
--- a/testsuite/tests/overloadedrecflds/should_run/all.T
+++ b/testsuite/tests/overloadedrecflds/should_run/all.T
@@ -8,3 +8,9 @@ test('overloadedrecfldsrun03', normal, compile_and_run, [''])
 test('overloadedrecfldsrun04', normal, compile_and_run, [''])
 test('overloadedrecfldsrun05', normal, compile_and_run, [''])
 test('overloadedrecfldsrun06', normal, compile_and_run, [''])
+test('overloadedlabelsrun01', normal, compile_and_run, [''])
+test('overloadedlabelsrun02', normal, compile_and_run, [''])
+test('overloadedlabelsrun03', normal, compile_and_run, [''])
+test('overloadedlabelsrun04',
+     extra_clean(['OverloadedLabelsRun04_A.hi', 'OverloadedLabelsRun04_A.o']),
+     multimod_compile_and_run, ['overloadedlabelsrun04', ''])
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs
new file mode 100644
index 0000000000..45c7854e64
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs
@@ -0,0 +1,29 @@
+-- Basic tests of overloaded labels
+
+{-# LANGUAGE OverloadedLabels
+           , DataKinds
+           , FlexibleContexts
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , NoMonomorphismRestriction
+  #-}
+
+import GHC.OverloadedLabels
+
+instance IsLabel "true" Bool where
+  fromLabel _ = True
+
+instance IsLabel "false" Bool where
+  fromLabel _ = False
+
+a :: IsLabel "true" t => t
+a = #true
+
+b = #false
+
+c :: Bool
+c = #true
+
+main = do print (a :: Bool)
+          print (b :: Bool)
+          print c
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout
new file mode 100644
index 0000000000..4644fbc1ec
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout
@@ -0,0 +1,3 @@
+True
+False
+True
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs
new file mode 100644
index 0000000000..eea8f36d40
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs
@@ -0,0 +1,61 @@
+-- Using overloaded labels to provide nice syntactic sugar for a
+-- term representation using de Bruijn indices
+
+{-# LANGUAGE OverloadedLabels
+           , DataKinds
+           , FlexibleContexts
+           , FlexibleInstances
+           , GADTs
+           , KindSignatures
+           , MultiParamTypeClasses
+           , NoMonomorphismRestriction
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , StandaloneDeriving
+           , TypeOperators
+  #-}
+
+import GHC.OverloadedLabels
+import Data.Proxy ( Proxy(..) )
+import GHC.TypeLits ( Symbol )
+
+instance x ~ y => IsLabel x (Proxy y) where
+  fromLabel _ = Proxy
+
+data Elem (x :: Symbol) g where
+  Top :: Elem x (x ': g)
+  Pop :: Elem x g -> Elem x (y ': g)
+deriving instance Show (Elem x g)
+
+
+class IsElem x g where
+  which :: Elem x g
+
+instance IsElem x (x ': g) where
+  which = Top
+
+instance IsElem x g => IsElem x (y ': g) where
+  which = Pop which
+
+
+data Tm g where
+  Var :: Elem x g -> Tm g
+  App :: Tm g -> Tm g -> Tm g
+  Lam :: Tm (x ': g) -> Tm g
+deriving instance Show (Tm g)
+
+instance IsElem x g => IsLabel x (Tm g) where
+  fromLabel _ = Var (which :: Elem x g)
+
+lam :: Proxy x -> Tm (x ': g) -> Tm g
+lam _ = Lam
+
+s = lam #x #x
+t = lam #x (lam #y (#x `App` #y))
+
+u :: IsElem "z" g => Tm g
+u = #z `App` #z
+
+main = do print s
+          print t
+          print (u :: Tm '["z"])
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.stdout
new file mode 100644
index 0000000000..ff2a4e75f0
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.stdout
@@ -0,0 +1,3 @@
+Lam (Var Top)
+Lam (Lam (App (Var (Pop Top)) (Var Top)))
+App (Var Top) (Var Top)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs
new file mode 100644
index 0000000000..a854d7ae07
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs
@@ -0,0 +1,21 @@
+-- Using overloaded labels as strings, slightly pointlessly
+
+{-# LANGUAGE OverloadedLabels
+           , DataKinds
+           , FlexibleContexts
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , ScopedTypeVariables
+           , TypeFamilies
+           , TypeSynonymInstances
+  #-}
+
+import GHC.OverloadedLabels
+import Data.Proxy ( Proxy(..) )
+import GHC.TypeLits ( KnownSymbol, symbolVal )
+
+instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where
+  fromLabel _ = symbolVal (Proxy :: Proxy x)
+
+main = do putStrLn #x
+          print $ #x ++ #y
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.stdout
new file mode 100644
index 0000000000..599697946c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.stdout
@@ -0,0 +1,2 @@
+x
+"xy"
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.hs
new file mode 100644
index 0000000000..8794a87b61
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedLabels, TemplateHaskell #-}
+
+import OverloadedLabelsRun04_A
+
+-- Who knew that there were so many ways that a line could start with
+-- a # sign in Haskell? None of these are overloaded labels:
+#line 7 "overloadedlabelsrun04.hs"
+# 8 "overloadedlabelsrun04.hs"
+#!notashellscript
+#pragma foo
+
+-- But this one is:
+#foo
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.stdout
new file mode 100644
index 0000000000..7326d96039
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.stdout
@@ -0,0 +1 @@
+Ok