git.iko.soy/rowtype-yoga/purescript-native
on c91c8d5 help sign in
rowtype-yoga/purescript-native/src/Data/Generics/Extras.hs
73 lines 2.2 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Data.Generics.Extras
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12-- Additional SYB combinators
13--
14-----------------------------------------------------------------------------
16{-# LANGUAGE Rank2Types #-}
18module Data.Generics.Extras where
20import Data.Data
22-- |
23-- Apply a top-down monadic transformation everywhere
24--
25everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d
26everywhereM' f x = do
27 y <- f x
28 gmapM (everywhereM' f) y
30-- |
31-- Apply a top-down transformation, mutating a state when descending from parents to children
32--
33-- For example, if we want to relabel bound variables with a different data constructor, we can do so:
34--
35-- > data Expr = Var String
36-- > | Lam String Test
37-- > | App Test Test
38-- > | LocalVar String deriving (Show, Data, Typeable)
39-- >
40-- > test = App (Lam "a" (App (Var "a") (Var "b"))) (Var "a")
41-- >
42-- > varsToLocals :: Expr -> Expr
43-- > varsToLocals = everywhereWithContext' [] (mkS go)
44-- > where
45-- > go locals (Var v) | v `elem` locals = (locals, LocalVar v)
46-- > go locals lam@(Lam local _) = (local : locals, lam)
47-- > go locals other = (locals, other)
48--
49everywhereWithContextM' :: (Monad m, Data d) => s -> (forall d1. (Data d1) => s -> d1 -> m (s, d1)) -> d -> m d
50everywhereWithContextM' s0 f x = do
51 (s, y) <- f s0 x
52 gmapM (everywhereWithContextM' s f) y
54-- |
55-- Make a stateful transformation function
56--
57mkS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> s -> b -> m (s, b)
58mkS = extS (curry return)
60-- |
61-- Extend a stateful transformation function
62--
63extS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> (s -> b -> m (s, b)) -> (s -> a -> m (s, a))
64extS f g s a = do
65 (s', a') <- f s a
66 case cast a' of
67 Just b -> do
68 (s'', b') <- g s' b
69 case cast b' of
70 Just a'' -> return (s'', a'')
71 Nothing -> return (s', a')
72 Nothing -> return (s', a')