support for multi-way-if

Test/examples/MultiWayIf.hs

@@ -4,3 +4,8 @@ module MultiWayIf where
 foo = if | test1 -> e1
          | test2 witharg -> e2
          | otherwise -> def
+
+bar = if { | test1 -> if { | test2 -> e1
+                           | test3 -> e2 }
+           | test4 -> e3
+         }

Test/failing.txt

@@ -17,5 +17,4 @@ IndentedWhereBlock.hs    Bug - needs fixes to layout parsing
 NegPrimWordLiteral.hs    Primitive word literals cannot be negative.
 RecordPuns.hs            Qualified record puns not yet supported.
 IndentedTopLevelWhere.hs Weird layout bug.
-MultiWayIf.hs            Multi-way if statements not yet supported.
 LambdaCase.hs            Lambda-case expressions not yet supported.

src/Language/Haskell/Exts/Annotated/ExactPrint.hs

@@ -1152,6 +1152,11 @@ instance ExactP Exp where
               _ -> errorEP "ExactP: Exp: If is given too few srcInfoPoints"
 
          _ -> errorEP "ExactP: Exp: If is given too few srcInfoPoints"
+    MultiIf l alts ->
+        case srcInfoPoints l of
+          a:pts -> do
+            printString "if"
+            layoutList pts alts
     Case l e alts   ->
         case srcInfoPoints l of
          a:b:pts -> do
@@ -1511,6 +1516,15 @@ instance ExactP GuardedAlt where
     bracketList ("|",",","->") (srcInfoPoints l) stmts
     exactPC e
 
+instance ExactP IfAlt where
+  exactP (IfAlt l e1 e2) =
+      case srcInfoPoints l of
+        a:b:pts -> do
+            printString "|"
+            exactPC e1
+            printStringAt (pos b) "->"
+            exactPC e2
+
 instance ExactP Match where
   exactP (Match l n ps rhs mbinds) = do
     let pts = srcInfoPoints l

src/Language/Haskell/Exts/Annotated/Fixity.hs

@@ -250,6 +250,10 @@ instance AppFixity GuardedAlt where
     applyFixities fixs (GuardedAlt l stmts e) = liftM2 (GuardedAlt l) (mapM fix stmts) (fix e)
       where fix x = applyFixities fixs x
 
+instance AppFixity IfAlt where
+    applyFixities y (IfAlt loc e1 e2) = liftM2 (IfAlt loc) (fix e1) (fix e2)
+      where fix x = applyFixities y x
+
 instance AppFixity QualStmt where
     applyFixities fixs qstmt = case qstmt of
         QualStmt     l s      -> liftM (QualStmt l) $ fix s
@@ -287,6 +291,7 @@ leafFix fixs e = case e of
     Lambda l pats e           -> liftM2 (Lambda l) (mapM fix pats) $ fix e
     Let l bs e                -> liftM2 (Let l) (fix bs) $ fix e
     If l e a b                -> liftM3 (If l) (fix e) (fix a) (fix b)
+    MultiIf l alts            -> liftM (MultiIf l) (mapM fix alts)
     Case l e alts             -> liftM2 (Case l) (fix e) $ mapM fix alts
     Do l stmts                -> liftM (Do l) $ mapM fix stmts
     MDo l stmts               -> liftM (MDo l) $ mapM fix stmts

src/Language/Haskell/Exts/Annotated/Simplify.hs

@@ -343,6 +343,7 @@ sExp e = case e of
     Lambda l ps e       -> S.Lambda (getPointLoc l) (map sPat ps) (sExp e)
     Let _ bs e          -> S.Let (sBinds bs) (sExp e)
     If _ e1 e2 e3       -> S.If (sExp e1) (sExp e2) (sExp e3)
+    MultiIf _ alts      -> S.MultiIf (map sIfAlt alts)
     Case _ e alts       -> S.Case (sExp e) (map sAlt alts)
     Do _ ss             -> S.Do (map sStmt ss)
     MDo _ ss            -> S.MDo (map sStmt ss)
@@ -524,3 +525,6 @@ sGuardedAlts galts = case galts of
 
 sGuardedAlt :: SrcInfo loc => GuardedAlt loc -> S.GuardedAlt
 sGuardedAlt (GuardedAlt l ss e) = S.GuardedAlt (getPointLoc l) (map sStmt ss) (sExp e)
+
+sIfAlt :: SrcInfo loc => IfAlt loc -> S.IfAlt
+sIfAlt (IfAlt _ e1 e2) = S.IfAlt (sExp e1) (sExp e2)

src/Language/Haskell/Exts/Annotated/Syntax.hs

@@ -59,7 +59,7 @@ module Language.Haskell.Exts.Annotated.Syntax (
     Type(..), Boxed(..), Kind(..), TyVarBind(..),
     -- * Expressions
     Exp(..), Stmt(..), QualStmt(..), FieldUpdate(..),
-    Alt(..), GuardedAlts(..), GuardedAlt(..), XAttr(..),
+    Alt(..), GuardedAlts(..), GuardedAlt(..), XAttr(..), IfAlt(..),
     -- * Patterns
     Pat(..), PatField(..), PXAttr(..), RPat(..), RPatOp(..),
     -- * Literals
@@ -702,6 +702,7 @@ data Exp l
     | Lambda l [Pat l] (Exp l)              -- ^ lambda expression
     | Let l (Binds l) (Exp l)               -- ^ local declarations with @let@ ... @in@ ...
     | If l (Exp l) (Exp l) (Exp l)          -- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/
+    | MultiIf l [IfAlt l]                   -- ^ @if@ @|@ /exp/ @->@ /exp/ ...
     | Case l (Exp l) [Alt l]                -- ^ @case@ /exp/ @of@ /alts/
     | Do l [Stmt l]                         -- ^ @do@-expression:
                                             --   the last statement in the list
@@ -1049,6 +1050,14 @@ data GuardedAlt l
   deriving (Eq,Ord,Show)
 #endif
 
+-- | An alternative in a multiway @if@ expression.
+data IfAlt l
+    = IfAlt l (Exp l) (Exp l)
+#ifdef __GLASGOW_HASKELL__
+  deriving (Eq,Ord,Show,Typeable,Data,Foldable,Traversable)
+#else
+  deriving (Eq,Ord,Show)
+#endif
 -----------------------------------------------------------------------------
 -- Builtin names.
 
@@ -1562,6 +1571,9 @@ instance Functor GuardedAlts where
 instance Functor GuardedAlt where
     fmap f (GuardedAlt l ss e) = GuardedAlt (f l) (map (fmap f) ss) (fmap f e)
 
+instance Functor IfAlt where
+    fmap f (IfAlt l e1 e2) = IfAlt (f l) (fmap f e1) (fmap f e2)
+
 -----------------------------------------------------------------------------
 -- Reading annotations
 
@@ -1954,6 +1966,7 @@ instance Annotated Exp where
         Lambda l ps e   -> l
         Let l bs e      -> l
         If l ec et ee   -> l
+        MultiIf l alts  -> l
         Case l e alts   -> l
         Do l ss         -> l
         MDo l ss        -> l
@@ -2253,3 +2266,7 @@ instance Annotated GuardedAlts where
 instance Annotated GuardedAlt where
     ann (GuardedAlt l ss e) = l
     amap f (GuardedAlt l ss e) = GuardedAlt (f l) ss e
+
+instance Annotated IfAlt where
+    ann (IfAlt l e1 e2) = l
+    amap f (IfAlt l e1 e2) = IfAlt (f l) e1 e2

src/Language/Haskell/Exts/Extension.hs

@@ -452,6 +452,10 @@ data KnownExtension =
   -- foreign function interface.
   | CApiFFI
 
+  -- | [GHC § 7.3.16] Enable the multi-way if-expressions
+  -- extension to accept conditional expressions with multiple branches.
+  | MultiWayIf
+
  {- Safe Haskell not yet supported by HSE.
 
   -- | [GHC § 7.20.3] Allow imports to be qualified with a safe

src/Language/Haskell/Exts/Fixity.hs

@@ -308,6 +308,10 @@ instance AppFixity GuardedAlt where
     applyFixities fixs (GuardedAlt loc stmts e) = liftM2 (GuardedAlt loc) (mapM fix stmts) (fix e)
       where fix x = applyFixities fixs x
 
+instance AppFixity IfAlt where
+    applyFixities y (IfAlt e1 e2) = liftM2 IfAlt (fix e1) (fix e2)
+      where fix x = applyFixities y x
+
 instance AppFixity QualStmt where
     applyFixities fixs qstmt = case qstmt of
         QualStmt     s      -> liftM QualStmt $ fix s
@@ -345,6 +349,7 @@ leafFix fixs e = case e of
     Lambda loc pats e       -> liftM2 (Lambda loc) (mapM fix pats) $ fix e
     Let bs e                -> liftM2 Let (fix bs) $ fix e
     If e a b                -> liftM3 If (fix e) (fix a) (fix b)
+    MultiIf alts            -> liftM MultiIf (mapM fix alts)
     Case e alts             -> liftM2 Case (fix e) $ mapM fix alts
     Do stmts                -> liftM Do $ mapM fix stmts
     MDo stmts               -> liftM MDo $ mapM fix stmts

src/Language/Haskell/Exts/InternalParser.ly

@@ -108,7 +108,7 @@ Conflicts: 7 shift/reduce
 -----------------------------------------------------------------------------
 
 > %token
->       VARID    { Loc _ (VarId _) }
+>       VARID    { Loc _ (VarId _) }       -- 1
 >       QVARID   { Loc _ (QVarId _) }
 >       IDUPID   { Loc _ (IDupVarId _) }       -- duplicable implicit parameter ?x
 >       ILINID   { Loc _ (ILinVarId _) }       -- linear implicit parameter %x
@@ -117,8 +117,8 @@ Conflicts: 7 shift/reduce
 >       DVARID   { Loc _ (DVarId _) }          -- VARID containing dashes
 >       VARSYM   { Loc _ (VarSym _) }
 >       CONSYM   { Loc _ (ConSym _) }
->       QVARSYM  { Loc _ (QVarSym _) }
->       QCONSYM  { Loc _ (QConSym _) }
+>       QVARSYM  { Loc _ (QVarSym _) } -- 10
+>       QCONSYM  { Loc _ (QConSym _) }      
 >       INT      { Loc _ (IntTok _) }
 >       RATIONAL { Loc _ (FloatTok _) }
 >       CHAR     { Loc _ (Character _) }
@@ -128,8 +128,8 @@ Conflicts: 7 shift/reduce
 >       PRIMWORD    { Loc _ (WordTokHash _) }
 >       PRIMFLOAT   { Loc _ (FloatTokHash _) }
 >       PRIMDOUBLE  { Loc _ (DoubleTokHash _) }
->       PRIMCHAR    { Loc _ (CharacterHash _) }
->       PRIMSTRING  { Loc _ (StringHash _) }
+>       PRIMCHAR    { Loc _ (CharacterHash _) } -- 20
+>       PRIMSTRING  { Loc _ (StringHash _) }  
 
 Symbols
 
@@ -141,7 +141,7 @@ Symbols
 >       '|}'    { Loc $$ RightCurlyBar }
 >       ';'     { Loc $$ SemiColon }
 >       '{'     { Loc $$ LeftCurly }
->       '}'     { Loc $$ RightCurly }
+>       '}'     { Loc $$ RightCurly }      -- 30
 >       vccurly { Loc $$ VRightCurly }                 -- a virtual close brace
 >       '['     { Loc $$ LeftSquare }
 >       ']'     { Loc $$ RightSquare }
@@ -154,8 +154,8 @@ Reserved operators
 >       '.'     { Loc $$ Dot }
 >       '..'    { Loc $$ DotDot }
 >       ':'     { Loc $$ Colon }
->       '::'    { Loc $$ DoubleColon }
->       '='     { Loc $$ Equals }
+>       '::'    { Loc $$ DoubleColon }      -- 40
+>       '='     { Loc $$ Equals }           
 >       '\\'    { Loc $$ Backslash }
 >       '|'     { Loc $$ Bar }
 >       '<-'    { Loc $$ LeftArrow }
@@ -164,8 +164,8 @@ Reserved operators
 >       '~'     { Loc $$ Tilde }
 >       '=>'    { Loc $$ DoubleArrow }
 >       '-'     { Loc $$ Minus }
->       '!'     { Loc $$ Exclamation }
->       '*'     { Loc $$ Star }
+>       '!'     { Loc $$ Exclamation }  -- 50
+>       '*'     { Loc $$ Star }           
 
 Arrows
 
@@ -183,8 +183,8 @@ Harp
 Template Haskell
 
 >       IDSPLICE        { Loc _ (THIdEscape _) }   -- $x
->       '$('            { Loc $$ THParenEscape }
->       '[|'            { Loc $$ THExpQuote }
+>       '$('            { Loc $$ THParenEscape } -- 60
+>       '[|'            { Loc $$ THExpQuote }     
 >       '[p|'           { Loc $$ THPatQuote }
 >       '[t|'           { Loc $$ THTypQuote }
 >       '[d|'           { Loc $$ THDecQuote }
@@ -196,8 +196,8 @@ Template Haskell
 Hsx
 
 >       PCDATA          { Loc _ (XPCDATA _) }
->       '<'             { Loc $$ XStdTagOpen }
->       '</'            { Loc $$ XCloseTagOpen }
+>       '<'             { Loc $$ XStdTagOpen }   -- 70
+>       '</'            { Loc $$ XCloseTagOpen }  
 >       '<%'            { Loc $$ XCodeTagOpen }
 >       '<%>'           { Loc $$ XChildTagOpen }
 >       '>'             { Loc $$ XStdTagClose }
@@ -209,8 +209,8 @@ Hsx
 FFI
 
 >       'foreign'       { Loc $$ KW_Foreign }
->       'export'        { Loc $$ KW_Export }
->       'safe'          { Loc $$ KW_Safe }
+>       'export'        { Loc $$ KW_Export }    -- 80
+>       'safe'          { Loc $$ KW_Safe }      
 >       'unsafe'        { Loc $$ KW_Unsafe }
 >       'threadsafe'    { Loc $$ KW_Threadsafe }
 >       'interruptible' { Loc $$ KW_Interruptible }
@@ -219,8 +219,8 @@ FFI
 >       'cplusplus'     { Loc $$ KW_CPlusPlus }
 >       'dotnet'        { Loc $$ KW_DotNet }
 >       'jvm'           { Loc $$ KW_Jvm }
->       'js'            { Loc $$ KW_Js }
->       'capi'          { Loc $$ KW_CApi }
+>       'js'            { Loc $$ KW_Js }          -- 90
+>       'capi'          { Loc $$ KW_CApi }      
 
 Reserved Ids
 
@@ -232,7 +232,7 @@ Reserved Ids
 >       'default'       { Loc $$ KW_Default }
 >       'deriving'      { Loc $$ KW_Deriving }
 >       'do'            { Loc $$ KW_Do }
->       'else'          { Loc $$ KW_Else }
+>       'else'          { Loc $$ KW_Else }     -- 100
 >       'family'        { Loc $$ KW_Family }   -- indexed type families
 >       'forall'        { Loc $$ KW_Forall }   -- universal/existential qualification
 >       'group'         { Loc $$ KW_Group }    -- transform list comprehensions
@@ -242,17 +242,17 @@ Reserved Ids
 >       'in'            { Loc $$ KW_In }
 >       'infix'         { Loc $$ KW_Infix }
 >       'infixl'        { Loc $$ KW_InfixL }
->       'infixr'        { Loc $$ KW_InfixR }
+>       'infixr'        { Loc $$ KW_InfixR }        -- 110
 >       'instance'      { Loc $$ KW_Instance }
 >       'let'           { Loc $$ KW_Let }
 >       'mdo'           { Loc $$ KW_MDo }
->       'module'        { Loc $$ KW_Module }
+>       'module'        { Loc $$ KW_Module }         -- 114
 >       'newtype'       { Loc $$ KW_NewType }
 >       'of'            { Loc $$ KW_Of }
 >       'proc'          { Loc $$ KW_Proc }     -- arrows
 >       'rec'           { Loc $$ KW_Rec }      -- arrows
 >       'then'          { Loc $$ KW_Then }
->       'type'          { Loc $$ KW_Type }
+>       'type'          { Loc $$ KW_Type }     -- 120
 >       'using'         { Loc $$ KW_Using }    -- transform list comprehensions
 >       'where'         { Loc $$ KW_Where }
 >       'qualified'     { Loc $$ KW_Qualified }
@@ -265,18 +265,18 @@ Pragmas
 >       '{-# SPECIALISE_INLINE' { Loc _ (SPECIALISE_INLINE _) }
 >       '{-# SOURCE'            { Loc $$ SOURCE }
 >       '{-# RULES'             { Loc $$ RULES }
->       '{-# CORE'              { Loc $$ CORE }
->       '{-# SCC'               { Loc $$ SCC }
+>       '{-# CORE'              { Loc $$ CORE }         -- 130
+>       '{-# SCC'               { Loc $$ SCC }       
 >       '{-# GENERATED'         { Loc $$ GENERATED }
 >       '{-# DEPRECATED'        { Loc $$ DEPRECATED }
 >       '{-# WARNING'           { Loc $$ WARNING }
 >       '{-# UNPACK'            { Loc $$ UNPACK }
 >       '{-# OPTIONS'           { Loc _ (OPTIONS _) }
        '{-# CFILES'            { Loc _ (CFILES  _) }
        '{-# INCLUDE'           { Loc _ (INCLUDE _) }
->       '{-# LANGUAGE'          { Loc $$ LANGUAGE }
+>       '{-# LANGUAGE'          { Loc $$ LANGUAGE }      -- 137
 >       '{-# ANN'               { Loc $$ ANN }
->       '#-}'                   { Loc $$ PragmaEnd }
+>       '#-}'                   { Loc $$ PragmaEnd }      -- 139
 
 
 > %monad { P }
@@ -1176,8 +1176,11 @@ mangle them into the correct form depending on context.
 >       : '\\' apats '->' exp             { Lambda (nIS $1 <++> ann $4 <** [$1,$3]) (reverse $2) $4 }
 A let may bind implicit parameters
 >       | 'let' binds 'in' exp            { Let    (nIS $1 <++> ann $4 <** [$1,$3])    $2 $4 }
->       | 'if' exp optlayoutsemi 'then' exp optlayoutsemi 'else' exp  
->	       	   	      	     	  { If     (nIS $1 <++> ann $8 <** ($1:$3 ++ $4:$6 ++ [$7])) $2 $5 $8 }
+>       | 'if' exp optlayoutsemi 'then' exp optlayoutsemi 'else' exp
+>                                        { If     (nIS $1 <++> ann $8 <** ($1:$3 ++ $4:$6 ++ [$7])) $2 $5 $8 }
+>       | 'if' ifaltslist                 {% checkEnabled MultiWayIf >>
+>                                            let (alts, inf, ss) = $2
+>                                            in return (MultiIf (nIS $1 <++> inf <** ($1:ss)) alts) }
 >       | 'proc' apat '->' exp            { Proc   (nIS $1 <++> ann $4 <** [$1,$3])    $2 $4 }
 >       | exppragma                       { $1 }
 
@@ -1501,7 +1504,7 @@ Case alternatives
 > gdpats :: { ([GuardedAlt L],L) }
 >       : gdpats gdpat                  { ($2 : fst $1, snd $1 <++> ann $2) }
 >       | gdpat                         { ([$1], ann $1) }
-
+ 
 A guard can be a pattern guard if PatternGuards is enabled, hence quals instead of exp0.
 > gdpat :: { GuardedAlt L }
 >       : '|' quals '->' trueexp {% do { checkPatternGuards (fst $2);
@@ -1511,6 +1514,21 @@ A guard can be a pattern guard if PatternGuards is enabled, hence quals instead
 > pat :: { Pat L }
 >       : exp                           {% checkPattern $1 }
 >       | '!' aexp                      {% checkPattern (BangPat (nIS $1 <++> ann $2 <** [$1]) $2) }
+
+> ifaltslist :: { ([IfAlt L], L, [S]) }
+>       : '{'  ifalts '}'                 { (fst $2, $1 <^^> $3, $1:snd $2 ++ [$3])  }
+>       | open ifalts close               { (fst $2, $1 <^^> $3, $1:snd $2 ++ [$3]) }
+
+> ifalts :: { ([IfAlt L], [S]) }
+>       : optsemis ifalts1 optsemis       { (reverse $ fst $2, $1 ++ snd $2 ++ $3) }
+
+> ifalts1 :: { ([IfAlt L], [S]) }
+>       : ifalts1 optsemis ifalt           { ($3 : fst $1, snd $1 ++ $2) }
+>       | ifalt                            { ([$1], []) }
+
+> ifalt :: { IfAlt L }
+>       : '|' trueexp '->' trueexp { let l = nIS $1 <++> ann $2 <++> ann $4 <** [$1,$3] in (IfAlt l $2 $4) }
+
 -----------------------------------------------------------------------------
 Statement sequences
 

src/Language/Haskell/Exts/ParseSyntax.hs

@@ -18,6 +18,7 @@ data PExp l
     | Lambda l [Pat l] (PExp l)             -- ^ lambda expression
     | Let l (Binds l) (PExp l)              -- ^ local declarations with @let@
     | If l (PExp l) (PExp l) (PExp l)       -- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/
+    | MultiIf l [IfAlt l]                   -- ^ @if@ @|@ /exp/ @->@ /exp/ ...
     | Case l (PExp l) [Alt l]               -- ^ @case@ /exp/ @of@ /alts/
     | Do l [Stmt l]                         -- ^ @do@-expression:
                                             --   the last statement in the list

src/Language/Haskell/Exts/ParseUtils.hs

@@ -543,6 +543,7 @@ checkExpr e = case e of
     Lambda loc ps e       -> check1Expr e (S.Lambda loc ps)
     Let l bs e            -> check1Expr e (S.Let l bs)
     If l e1 e2 e3         -> check3Exprs e1 e2 e3 (S.If l)
+    MultiIf l alts        -> return (S.MultiIf l alts)
     Case l e alts         -> do
                      e <- checkExpr e
                      return (S.Case l e alts)