diff options
Diffstat (limited to 'compiler/GHC/Parser.y')
| -rw-r--r-- | compiler/GHC/Parser.y | 49 |
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 |