Linear types (#15981)

This is the first step towards implementation of the linear types proposal
(https://github.com/ghc-proposals/ghc-proposals/pull/111).

It features

* A language extension -XLinearTypes
* Syntax for linear functions in the surface language
* Linearity checking in Core Lint, enabled with -dlinear-core-lint
* Core-to-core passes are mostly compatible with linearity
* Fields in a data type can be linear or unrestricted; linear fields
  have multiplicity-polymorphic constructors.
  If -XLinearTypes is disabled, the GADT syntax defaults to linear fields

The following items are not yet supported:

* a # m -> b syntax (only prefix FUN is supported for now)
* Full multiplicity inference (multiplicities are really only checked)
* Decent linearity error messages
* Linear let, where, and case expressions in the surface language
  (each of these currently introduce the unrestricted variant)
* Multiplicity-parametric fields
* Syntax for annotating lambda-bound or let-bound with a multiplicity
* Syntax for non-linear/multiple-field-multiplicity records
* Linear projections for records with a single linear field
* Linear pattern synonyms
* Multiplicity coercions (test LinearPolyType)

A high-level description can be found at
https://ghc.haskell.org/trac/ghc/wiki/LinearTypes/Implementation
Following the link above you will find a description of the changes made to Core.
This commit has been authored by

* Richard Eisenberg
* Krzysztof Gogolewski
* Matthew Pickering
* Arnaud Spiwack

With contributions from:

* Mark Barbone
* Alexander Vershilov

Updates haddock submodule.

1 files changed, 36 insertions, 13 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 07e7572092..3fddd993fe 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -74,7 +74,7 @@ import GHC.Unit.Module
 import GHC.Types.Basic
 import GHC.Types.ForeignCall
 
-import GHC.Core.Type    ( funTyCon, Specificity(..) )
+import GHC.Core.Type    ( unrestrictedFunTyCon, Mult(..), Specificity(..) )
 import GHC.Core.Class   ( FunDep )
 
 -- compiler/parser
@@ -89,7 +89,8 @@ import GHC.Tc.Types.Evidence  ( emptyTcEvBinds )
 import GHC.Builtin.Types.Prim ( eqPrimTyCon )
 import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
                            unboxedUnitTyCon, unboxedUnitDataCon,
-                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
+                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR,
+                           manyDataConTyCon)
 }
 
 %expect 232 -- shift/reduce conflicts
@@ -540,6 +541,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
  '|'            { L _ ITvbar }
  '<-'           { L _ (ITlarrow _) }
  '->'           { L _ (ITrarrow _) }
+ '#->'          { L _ (ITlolly _) }
  TIGHT_INFIX_AT { L _ ITat }
  '=>'           { L _ (ITdarrow _) }
  '-'            { L _ ITminus }
@@ -642,9 +644,9 @@ identifier :: { Located RdrName }
         | qcon                          { $1 }
         | qvarop                        { $1 }
         | qconop                        { $1 }
-    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)
+    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
                                [mop $1,mu AnnRarrow $2,mcp $3] }
-    | '->'              {% ams (sLL $1 $> $ getRdrName funTyCon)
+    | '->'              {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
                                [mu AnnRarrow $1] }
 
 -----------------------------------------------------------------------------
@@ -2000,27 +2002,41 @@ is connected to the first type too.
 type :: { LHsType GhcPs }
         : btype                        { $1 }
         | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
-                                       >> ams (sLL $1 $> $ HsFunTy noExtField $1 $3)
+                                       >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3)
                                               [mu AnnRarrow $2] }
 
+        | btype '#->' ctype             {% hintLinear (getLoc $2) >>
+                                         ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
+                                             [mu AnnRarrow $2] }
+
+mult :: { LHsType GhcPs }
+        : btype                  { $1 }
+
 
 typedoc :: { LHsType GhcPs }
         : btype                          { $1 }
         | btype docprev                  { sLL $1 $> $ HsDocTy noExtField $1 $2 }
         | docnext btype                  { sLL $1 $> $ HsDocTy noExtField $2 $1 }
         | btype '->'     ctypedoc        {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
-                                         >> ams (sLL $1 $> $ HsFunTy noExtField $1 $3)
+                                         >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3)
                                                 [mu AnnRarrow $2] }
         | btype docprev '->' ctypedoc    {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
                                          >> ams (sLL $1 $> $
-                                                 HsFunTy noExtField (L (comb2 $1 $2)
-                                                            (HsDocTy noExtField $1 $2))
-                                                         $4)
+                                                 HsFunTy noExtField HsUnrestrictedArrow
+                                                         (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4)
+                                                [mu AnnRarrow $3] }
+        | btype '#->'     ctypedoc       {% hintLinear (getLoc $2) >>
+                                           ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
+                                                [mu AnnRarrow $2] }
+        | btype docprev '#->' ctypedoc   {% hintLinear (getLoc $2) >>
+                                           ams (sLL $1 $> $
+                                                 HsFunTy noExtField HsLinearArrow
+                                                         (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4)
                                                 [mu AnnRarrow $3] }
         | docnext btype '->' ctypedoc    {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
                                          >> ams (sLL $1 $> $
-                                                 HsFunTy noExtField (L (comb2 $1 $2)
-                                                            (HsDocTy noExtField $2 $1))
+                                                 HsFunTy noExtField HsUnrestrictedArrow
+                                                         (L (comb2 $1 $2) (HsDocTy noExtField $2 $1))
                                                          $4)
                                                 [mu AnnRarrow $3] }
 
@@ -3484,7 +3500,7 @@ ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit
         | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
                                                         (snd $2 + 1)))
                                        (mo $1:mc $3:(mcommas (fst $2))) }
-        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)
+        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
                                        [mop $1,mu AnnRarrow $2,mcp $3] }
         | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }
 
@@ -3568,7 +3584,7 @@ tyconsym :: { Located RdrName }
 op      :: { Located RdrName }   -- used in infix decls
         : varop                 { $1 }
         | conop                 { $1 }
-        | '->'                  { sL1 $1 $ getRdrName funTyCon }
+        | '->'                  { sL1 $1 $ getRdrName unrestrictedFunTyCon }
 
 varop   :: { Located RdrName }
         : varsym                { $1 }
@@ -3985,6 +4001,13 @@ fileSrcSpan = do
   let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)
 
+-- Hint about linear types
+hintLinear :: SrcSpan -> P ()
+hintLinear span = do
+  linearEnabled <- getBit LinearTypesBit
+  unless linearEnabled $ addError span $
+    text "Enable LinearTypes to allow linear functions"
+
 -- Hint about the MultiWayIf extension
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do