Ticket #4359: multi-way-if-th.patch

File multi-way-if-th.patch, 5.2 KB (added by mikhail.vorozhtsov, 10 months ago)

MultiWayIf, patch for the template-haskell library

  • Language/Haskell/TH.hs 

    From bc5797c31a154efe3d2ca857ae8ace710001e5c0 Mon Sep 17 00:00:00 2001
From: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>
Date: Sun, 15 Jul 2012 00:56:17 +0700
Subject: [PATCH] Added multi-way if-expressions support.

---
 Language/Haskell/TH.hs        |  2 +-
 Language/Haskell/TH/Lib.hs    |  3 +++
 Language/Haskell/TH/Ppr.hs    | 24 ++++++++++++++++++------
 Language/Haskell/TH/PprLib.hs |  4 +++-
 Language/Haskell/TH/Syntax.hs |  1 +
 5 files changed, 26 insertions(+), 8 deletions(-)

diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs
index fc4722f..8e36af7 100644
    a b  
    5656    -- *** Expressions 
    5757        dyn, global, varE, conE, litE, appE, uInfixE, parensE, 
    5858        infixE, infixApp, sectionL, sectionR, 
    59         lamE, lam1E, lamCaseE, tupE, condE, letE, caseE, appsE, 
     59        lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, 
    6060        listE, sigE, recConE, recUpdE, stringE, fieldExp, 
    6161    -- **** Ranges 
    6262    fromE, fromThenE, fromToE, fromThenToE, 

  • Language/Haskell/TH/Lib.hs 

    diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs
index 1edeb0b..52865ad 100644
    a b  
    254254condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ 
    255255condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)} 
    256256 
     257multiIfE :: [Q (Guard, Exp)] -> ExpQ 
     258multiIfE alts = sequence alts >>= return . MultiIfE 
     259 
    257260letE :: [DecQ] -> ExpQ -> ExpQ 
    258261letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } 
    259262 

  • Language/Haskell/TH/Ppr.hs 

    diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs
index a53fffe..a1d08e2 100644
    a b  
    115115 = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard, 
    116116                       nest 1 $ text "then" <+> ppr true, 
    117117                       nest 1 $ text "else" <+> ppr false] 
     118pprExp i (MultiIfE alts) 
     119  = parensIf (i > noPrec) $ vcat $ 
     120      case alts of 
     121        []            -> [text "if {}"] 
     122        (alt : alts') -> text "if" <+> pprGuarded arrow alt 
     123                         : map (nest 3 . pprGuarded arrow) alts' 
    118124pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds 
    119125                                            $$ text " in" <+> ppr e 
    120126pprExp i (CaseE e ms) 
    … …  
    156162                        $$ where_clause ds 
    157163 
    158164------------------------------ 
     165pprGuarded :: Doc -> (Guard, Exp) -> Doc 
     166pprGuarded eqDoc (guard, expr) = case guard of 
     167  NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr 
     168  PatG    stmts     -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$  
     169                         nest nestDepth (eqDoc <+> ppr expr) 
     170 
     171------------------------------ 
    159172pprBody :: Bool -> Body -> Doc 
    160 pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs 
    161   where eqd = if eq then text "=" else text "->" 
    162         do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e 
    163         do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss) 
    164                              $$ nest nestDepth (eqd <+> ppr e) 
    165 pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e 
     173pprBody eq body = case body of 
     174    GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs 
     175    NormalB  e  -> eqDoc <+> ppr e 
     176  where eqDoc | eq        = equals 
     177              | otherwise = arrow 
    166178 
    167179------------------------------ 
    168180pprLit :: Precedence -> Lit -> Doc 

  • Language/Haskell/TH/PprLib.hs 

    diff --git a/Language/Haskell/TH/PprLib.hs b/Language/Haskell/TH/PprLib.hs
index e42c986..42856bb 100644
    a b  
    1010 
    1111        -- * Primitive Documents 
    1212        empty, 
    13         semi, comma, colon, space, equals, 
     13        semi, comma, colon, space, equals, arrow, 
    1414        lparen, rparen, lbrack, rbrack, lbrace, rbrace, 
    1515 
    1616        -- * Converting values into documents 
    … …  
    6363colon   :: Doc;                 -- ^ A ':' character 
    6464space   :: Doc;                 -- ^ A space character 
    6565equals  :: Doc;                 -- ^ A '=' character 
     66arrow   :: Doc;                 -- ^ A "->" string 
    6667lparen  :: Doc;                 -- ^ A '(' character 
    6768rparen  :: Doc;                 -- ^ A ')' character 
    6869lbrack  :: Doc;                 -- ^ A '[' character 
    … …  
    163164colon = return HPJ.colon 
    164165space = return HPJ.space 
    165166equals = return HPJ.equals 
     167arrow = return $ HPJ.text "->" 
    166168lparen = return HPJ.lparen 
    167169rparen = return HPJ.rparen 
    168170lbrack = return HPJ.lbrack 

  • Language/Haskell/TH/Syntax.hs 

    diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs
index 65aff77..d9c1dcc 100644
    a b  
    866866  | TupE [Exp]                         -- ^ @{ (e1,e2) }  @ 
    867867  | UnboxedTupE [Exp]                  -- ^ @{ (# e1,e2 #) }  @ 
    868868  | CondE Exp Exp Exp                  -- ^ @{ if e1 then e2 else e3 }@ 
     869  | MultiIfE [(Guard, Exp)]            -- ^ @{ if | g1 -> e1 | g2 -> e2 }@ 
    869870  | LetE [Dec] Exp                     -- ^ @{ let x=e1;   y=e2 in e3 }@ 
    870871  | CaseE Exp [Match]                  -- ^ @{ case e of m1; m2 }@ 
    871872  | DoE [Stmt]                         -- ^ @{ do { p <- e1; e2 }  }@