From a7ef7551b3bc078c6992619e3fe847324b074d24 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 22 Mar 2019 17:40:54 -0400 Subject: Apply do-syntax. --- Sweeten.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 Sweeten.hs (limited to 'Sweeten.hs') diff --git a/Sweeten.hs b/Sweeten.hs new file mode 100644 index 0000000..929f9f8 --- /dev/null +++ b/Sweeten.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Sweeten where + +import Data.Data +import Data.Generics.Aliases +import Data.Generics.Schemes +import Language.Haskell.Exts.Syntax as HS + +applyDoSyntax :: forall l. (Typeable l, Data l) => Exp l -> Exp l +applyDoSyntax = everywhere (mkT (applyDoSyntax1 :: Exp l -> Exp l)) + +applyDoSyntax1 :: Exp l -> Exp l +applyDoSyntax1 exp@(InfixApp la x (QVarOp lb (UnQual lc (Symbol ld ">>="))) (Lambda le [pat] y)) = + case y of + Do lf ss -> Do la (Generator lb pat x : ss) + _ -> Do la [Generator lb pat x, Qualifier le y] +applyDoSyntax1 exp@(InfixApp la x (QVarOp lb (UnQual lc (Symbol ld ">>"))) y) = + case y of + Do lf ss -> Do la (Qualifier lb x : ss) + _ -> Do la [Qualifier lb x, Qualifier lc y] +applyDoSyntax1 exp = exp -- cgit v1.2.3