git.iko.soy/rowtype-yoga/purescript-native
on eded2bd help sign in
rowtype-yoga/purescript-native/src/Data/Generics/Extras.hs
65 lines 1.9 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 transformation, mutating a state when descending from parents to children
24--
25-- For example, if we want to relabel bound variables with a different data constructor, we can do so:
26--
27-- > data Expr = Var String
28-- > | Lam String Test
29-- > | App Test Test
30-- > | LocalVar String deriving (Show, Data, Typeable)
31-- >
32-- > test = App (Lam "a" (App (Var "a") (Var "b"))) (Var "a")
33-- >
34-- > varsToLocals :: Expr -> Expr
35-- > varsToLocals = everywhereWithContext' [] (mkS go)
36-- > where
37-- > go locals (Var v) | v `elem` locals = (locals, LocalVar v)
38-- > go locals lam@(Lam local _) = (local : locals, lam)
39-- > go locals other = (locals, other)
40--
41everywhereWithContextM' :: (Monad m, Data d) => s -> (forall d1. (Data d1) => s -> d1 -> m (s, d1)) -> d -> m d
42everywhereWithContextM' s0 f x = do
43 (s, y) <- f s0 x
44 gmapM (everywhereWithContextM' s f) y
46-- |
47-- Make a stateful transformation function
48--
49mkS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> s -> b -> m (s, b)
50mkS = extS (curry return)
52-- |
53-- Extend a stateful transformation function
54--
55extS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> (s -> b -> m (s, b)) -> (s -> a -> m (s, a))
56extS f g s a = do
57 (s', a') <- f s a
58 case cast a' of
59 Just b -> do
60 (s'', b') <- g s' b
61 case cast b' of
62 Just a'' -> return (s'', a'')
63 Nothing -> return (s', a')
64 Nothing -> return (s', a')