diff options
author | Joe Crayne <joe@jerkface.net> | 2019-03-22 17:40:54 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-03-22 17:40:54 -0400 |
commit | a7ef7551b3bc078c6992619e3fe847324b074d24 (patch) | |
tree | ad63ea9890ba75bfc8d6c51f6a288e46e164b2cf /Sweeten.hs | |
parent | b511cbf06b5ad30a555c5bf99598b7257d628eea (diff) |
Apply do-syntax.
Diffstat (limited to 'Sweeten.hs')
-rw-r--r-- | Sweeten.hs | 21 |
1 files changed, 21 insertions, 0 deletions
diff --git a/Sweeten.hs b/Sweeten.hs new file mode 100644 index 0000000..929f9f8 --- /dev/null +++ b/Sweeten.hs | |||
@@ -0,0 +1,21 @@ | |||
1 | {-# LANGUAGE ScopedTypeVariables #-} | ||
2 | module Sweeten where | ||
3 | |||
4 | import Data.Data | ||
5 | import Data.Generics.Aliases | ||
6 | import Data.Generics.Schemes | ||
7 | import Language.Haskell.Exts.Syntax as HS | ||
8 | |||
9 | applyDoSyntax :: forall l. (Typeable l, Data l) => Exp l -> Exp l | ||
10 | applyDoSyntax = everywhere (mkT (applyDoSyntax1 :: Exp l -> Exp l)) | ||
11 | |||
12 | applyDoSyntax1 :: Exp l -> Exp l | ||
13 | applyDoSyntax1 exp@(InfixApp la x (QVarOp lb (UnQual lc (Symbol ld ">>="))) (Lambda le [pat] y)) = | ||
14 | case y of | ||
15 | Do lf ss -> Do la (Generator lb pat x : ss) | ||
16 | _ -> Do la [Generator lb pat x, Qualifier le y] | ||
17 | applyDoSyntax1 exp@(InfixApp la x (QVarOp lb (UnQual lc (Symbol ld ">>"))) y) = | ||
18 | case y of | ||
19 | Do lf ss -> Do la (Qualifier lb x : ss) | ||
20 | _ -> Do la [Qualifier lb x, Qualifier lc y] | ||
21 | applyDoSyntax1 exp = exp | ||