packages feed

arrowp-qq 0.2.1.1 → 0.3.0

raw patch · 12 files changed

+801/−237 lines, 12 filesdep ~Hoeddep ~NoHoeddep ~basenew-component:exe:arrowpnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Hoed, NoHoed, base, containers, data-default, haskell-src-exts, haskell-src-exts-util, haskell-src-meta, template-haskell, transformers, uniplate

API changes (from Hackage documentation)

+ Control.Arrow.QuasiQuoter: procEx :: ParseMode -> QuasiQuoter

Files

README.md view
@@ -2,37 +2,57 @@ [![Stackage Nightly](http://stackage.org/package/arrowp-qq/badge/nightly)](http://stackage.org/nightly/package/arrowp-qq) [![Travis Build Status](https://travis-ci.org/pepeiborra/arrowp-qq.svg)](https://travis-ci.org/pepeiborra/arrowp-qq) -Arrowp-qq+arrowp-qq ==========-A preprocessor for arrow notation -based on the arrowp preprocessor developed by Ross Paterson <ross@soi.city.ac.uk>.+A preprocessor (aka syntax-desugarer) for arrow notation +based on the original `arrowp` developed by Ross Paterson <ross@soi.city.ac.uk>. -Notable features include support for GHC Haskell syntax and a-quasiquoter that can be used instead of the preprocessor.+`arrowp-qq` extends the original `arrowp` in three dimensions:+1. It replaces the `haskell-src` based parser with one based on `haskell-src-exts`, which handles most of GHC 8.0.2 Haskell syntax.+2. It provides not only a preprocessor but also a quasiquoter, which is a better option in certain cases.+3. It extends the desugaring to handle static conditional expressions. See the semantics section below for more details. -Note that recent versions of GHC support this notation directly, and-give better error messages to boot. But the translation produced by GHC-is in some cases not as good as it could be.+Note: `arrowp-qq` provides an enhanced superset of the original `arrowp`'s functionality. One should have no reason to install both. Considering `arrowp` no longer builds under modern versions of GHC and Cabal/Stack, `arrowp-qq` should clearly be the more optimum package to install. -Status+Both `arrowp` and `arrowp-qq` were originally developed during the days when GHC's `Arrows` extension was not fully mature--a time when `proc` syntax was not the norm. Of course, recent versions of GHC now support this notation directly, and give better error messages to boot. Unfortunately, GHC's `proc` notation desugarer is in some cases not as good as it could be. As such, `arrowp-qq`'s quasi-quoter can still be useful in producing slightly more optimized desugaring for performance-critical, arrowized applications.++The modern use cases of `arrowp-qq` are as follows:+- Viewing how your `proc` blocks (roughly) look like after desugaring for debugging/profiling purposes.+  - Via the `arrowp` executable.+  - NOTE: `arrowp-qq` is NOT guaranteed to produce the same desugaring as GHC (see limitations & semantics below).+- Optimizing the performance of your `proc` blocks via smarter desugaring.+  - Either through the `arrowp` executable OR (preferably) the provided quasiquoter.++Limitations ------  The parser cannot handle banana brackets for control operators in arrow notation (the **proc** keyword in the original paper), -due to a -[limitation](https://github.com/haskell-suite/haskell-src-exts/issues/45) -in haskell-src-exts. In order to use banana brackets, the recommendation-is to fall back to the GHC Arrows parser. +due to a [limitation](https://github.com/haskell-suite/haskell-src-exts/issues/45) +in `haskell-src-exts`. In order to use banana brackets, the recommendation+is to fall back to the GHC Arrows parser.  Support for GHC Haskell notation inside arrow blocks is not complete, e.g. multi-way-if and lambda case are unlikely to work as expected. If you run into  one of these, please open an issue or vote for an existing one, as I plan to extend the support on demand. -Using the `proc` quasi quoter----------------------------+Installation+------------+`arrowp-qq` is now compatible with Cabal v3's Nix-style local builds & installs: +`cabal install arrowp-qq`++Usage +-----+### Viewing desugared `proc` syntax+```sh+arrowp myfile.hs | less ```+### Optimization+#### Via the `proc` quasiquoter++``` addA :: Arrow a => a b Int -> a b Int -> a b Int addA f g = [proc| x -> do 		y <- f -< x@@ -40,19 +60,17 @@ 		returnA -< y + z |] ``` -Using the **arrowp-ext** preprocessor-----------------------------------+#### Via the **arrowp** preprocessor+Add the following GHC pragma to the top of the source file: ```-{-# OPTIONS -F -pgmF arrowp-ext #-}+{-###  OPTIONS -F -pgmF arrowp ### -} ```+This can be useful for preserving compatibility with vanilla `proc` notation, at the cost of flexibility; that is to say, all `proc` blocks within the source file will be desugared via `arrowp-qq`. -Comparison with **arrowp**+Desugaring Semantics ------------------------**arrowp-qq** extends the original **arrowp** in three dimensions:-1. It replaces the `haskell-src` based parser with one based on `haskell-src-exts`, which handles most of GHC 8.0.2 Haskell syntax.-2. It provides not only a preprocessor but also a quasiquoter, which is a better option in certain cases.-3. It extends the desugaring to handle static conditional expressions. Example:+### Static conditional expression optimization+As mentioned previously, `arrowp-qq` extends the original `arrowp`'s desugaring to handle static conditional expressions. Given: ``` proc inputs -> do   results <- processor -< inputs@@ -61,7 +79,7 @@     else returnA -< ()   returnA -< results ```-The standard **arrowp** (and GHC) desugaring for this code is:+The standard `arrowp` (and GHC) desugaring for this code is: ```   = ((processor >>> arr (\ results -> (results, results))) >>>        (first@@ -79,8 +97,7 @@           >>> arr (\ (_, results) -> results))) ``` -Comparison with **GHC**------------------------+### `first` call optimization The GHC desugarer does not do a very good job of minimizing the number of `first` calls inserted. In certain `Arrow` instances, this can have a material effect on performance. Example:
arrowp-qq.cabal view
@@ -1,11 +1,11 @@ Name:           arrowp-qq-Version:        0.2.1.1-Cabal-Version:  >= 1.20+Version:        0.3.0+Cabal-Version:  >= 2.0 Build-Type:     Simple License:        GPL License-File:   LICENCE Author:         Jose Iborra <pepeiborra@gmail.com>-Maintainer:     Jose Iborra <pepeiborra@gmail.com>+Maintainer:     John 'Ski <riuga@tuta.io> Homepage:       https://github.com/pepeiborra/arrowp Category:       Development Synopsis:       A preprocessor and quasiquoter for translating arrow notation@@ -30,43 +30,42 @@     Exposed-Modules:                               Control.Arrow.Notation,                          Control.Arrow.QuasiQuoter-    Build-Depends: base < 5,-                   containers,-                   data-default,-                   haskell-src-exts,-                   haskell-src-exts-util >= 0.2.0,-                   haskell-src-meta,-                   template-haskell < 2.13, -                   transformers,-                   uniplate+    Build-Depends: base                   >= 4.7 && < 5,+                   NoHoed                 >= 0.1.1 && < 0.2,+                   template-haskell       >= 2.14.0 && < 2.15,+                   containers             >= 0.6.0 && < 0.7,+                   data-default           >= 0.7.1 && < 0.8,+                   haskell-src-exts       >= 1.22.0 && < 1.23,+                   transformers           >= 0.5.6 && < 0.6,+                   haskell-src-exts-util  >= 0.2.5 && < 0.3,+                   uniplate               >= 1.6.12 && < 1.7,+                   haskell-src-meta       >= 0.8.5 && < 0.9     if flag(Debug)-       Build-Depends:       Hoed, haskell-src-exts-observe+       Build-Depends:       Hoed > 0.3.6, haskell-src-exts-observe        cpp-options:         -DDEBUG     else-       Build-Depends:       NoHoed+       Build-Depends:       NoHoed >= 0.1.1      Hs-Source-Dirs: src     Other-Modules:  ArrCode ArrSyn NewCode SrcLocs Utils     Default-Language:    Haskell2010 -executable arrowp-ext+executable arrowp   buildable: True   main-is: Main.hs   hs-source-dirs:       app   build-depends:-                base >= 4.7 && < 5, -                arrowp-qq,-                haskell-src-exts+      base, haskell-src-exts, arrowp-qq   if flag(Debug)       Build-Depends:       Hoed       cpp-options:         -DDEBUG   else       Build-Depends:       NoHoed-   default-language: Haskell2010  test-suite examples+  default-language: Haskell2010   if flag(TestExamples)      buildable: True   else@@ -84,7 +83,11 @@                        Parser,                        ExprParser,                        BackstateArrow,+                       ArrowContext,+                       CGI,                        Conditional,+                       Circuits,+                       Hom,                        ListOps,                        Egs,                        Eval,
examples/Conditional.hs view
@@ -16,6 +16,6 @@      else returnA -< c -- :: a (b,c) c   returnA -< res -simple :: Bool -> a b c -> a b c+simple :: (Arrow a) => Bool -> a b c -> a b c simple use abc = proc b -> do   if use then abc -< b else abc -< b
+ examples/cgi/ArrowContext.lhs view
@@ -0,0 +1,152 @@+> {-# LANGUAGE DatatypeContexts #-}+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE FlexibleInstances #-}+> {-# LANGUAGE MultiParamTypeClasses #-}+> {-# OPTIONS -F -pgmF arrowp-ext #-}++Basic definitions from "Generalising Monads to Arrows", by John Hughes,+but with the Arrow class split and generalized.++> module ArrowContext where++> import Control.Monad++> infixr 5 <+>+> infixr 3 ***+> infixr 3 &&&+> infixr 2 ++++> infixr 2 |||+> infixr 1 >>>++Basic arrow definitions (s4.1)++> class Arrow a where+>	arr :: (b -> c) -> a b c+>	(>>>) :: a b c -> a c d -> a b d++> class Arrow a => ArrowContext a d where+>	first :: a b c -> a (b,d) (c,d)++> newtype Kleisli m a b = Kleisli (a -> m b)++> instance Monad m => Arrow (Kleisli m) where+>	arr f = Kleisli (return . f)+>	(Kleisli f) >>> (Kleisli g) = Kleisli (\b -> f b >>= g)++> instance Monad m => ArrowContext (Kleisli m) d where+>	first (Kleisli f) = Kleisli (\(b,d) -> f b >>= \c -> return (c,d))++> second :: ArrowContext a d => a b c -> a (d,b) (d,c)+> second f = arr swap >>> first f >>> arr swap+>		where	swap ~(x,y) = (y,x)++> (***) :: (ArrowContext a b', ArrowContext a c) =>+>	a b c -> a b' c' -> a (b,b') (c,c')+> f *** g = first f >>> second g++> (&&&) :: (ArrowContext a b, ArrowContext a c) =>+>	a b c -> a b c' -> a b (c,c')+> f &&& g = arr (\b -> (b,b)) >>> f *** g++> liftA2 :: (ArrowContext a b, ArrowContext a e) =>+>	(b -> c -> d) -> a e b -> a e c -> a e d+> liftA2 op f g = f &&& g >>> arr (uncurry op)++ArrowPlus and ArrowZero (s4.2)++> class Arrow a => ArrowZero a where+>	zeroArrow :: a b c++> class ArrowZero a => ArrowPlus a where+>	(<+>) :: a b c -> a b c -> a b c++> instance MonadPlus m => ArrowZero (Kleisli m) where+>	zeroArrow = Kleisli (\x -> mzero)++> instance MonadPlus m => ArrowPlus (Kleisli m) where+>	Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)++Conditionals (s5.1)++> class Arrow a => ArrowChoice a where+>	left :: a b c -> a (Either b d) (Either c d)++> instance Monad m => ArrowChoice (Kleisli m) where+>	left (Kleisli f) = Kleisli g+>		where	g (Left b) = f b >>= (return . Left)+>			g (Right d) = return (Right d)++> right :: ArrowChoice a => a b c -> a (Either d b) (Either d c)+> right f = arr mirror >>> left f >>> arr mirror+>		where	mirror (Left x) = Right x+>			mirror (Right y) = Left y++> (+++) :: ArrowChoice a => a b c -> a b' c' -> a (Either b b') (Either c c')+> f +++ g = left f >>> right g++> (|||) :: ArrowChoice a => a b d -> a c d -> a (Either b c) d+> f ||| g = f +++ g >>> arr untag+>		where	untag (Left x) = x+>			untag (Right y) = y++> test :: (ArrowContext a Bool, ArrowContext a b) =>+>	a b Bool -> a b (Either b b)+> test f = f &&& arr id >>> arr (\(b, x) -> if b then Left x else Right x)++Application (s5.2)++> class Arrow a => ArrowApply a where+>	app :: a (a b c, b) c++> leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)+> leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||+>		 (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app++> instance Monad m => ArrowApply (Kleisli m) where+>	app = Kleisli (\(Kleisli f, x) -> f x)++> newtype ArrowApply a => ArrowMonad a b = ArrowMonad (a () b)++> instance ArrowApply a => Functor (ArrowMonad a) where+>   fmap = liftM++> instance ArrowApply a => Applicative (ArrowMonad a) where+>   pure = return+>   (<*>) = ap++> instance ArrowApply a => Monad (ArrowMonad a) where+>	return x = ArrowMonad (arr (\z -> x))+>	ArrowMonad m >>= f = ArrowMonad (m >>>+>			arr (\x -> let ArrowMonad h = f x in (h, ())) >>>+>			app)++The ordinary function type (s7)++> instance Arrow (->) where+>	arr f = f+>	f >>> g = g . f++> instance ArrowContext (->) a where+>	first f (x,y) = (f x, y)++> instance ArrowChoice (->) where+>	left f (Left x) = Left (f x)+>	left f (Right y) = Right y++> instance ArrowApply (->) where+>	app (f,x) = f x++Auxiliary functions used in stating laws (s7)++> assoc :: ((a,b),c) -> (a,(b,c))+> assoc ~(~(x,y),z) = (x,(y,z))++> assocsum :: Either (Either a b) c -> Either a (Either b c)+> assocsum (Left (Left x)) = Left x+> assocsum (Left (Right y)) = Right (Left y)+> assocsum (Right z) = Right (Right z)++Another definition used by the arrow notation.++> returnA :: Arrow a => a b b+> returnA = arr id
+ examples/cgi/CGI.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS -F -pgmF arrowp-ext #-}+-- CGI library from Hughes's paper (s.10)++-- This is just an exploratory formulation: it type-checks, but+-- it doesn't actually do anything.++module CGI where++-- Note that this requires a special generalized version of the arrow+-- library, with a special class for first and associates.+++import           ArrowContext++data ScriptState+	= Ask+	| Comp (Either ScriptState ScriptState)+	| First ScriptState String++data Input a = Initial a | Resume ScriptState String+data Output a = Final a | Suspend ScriptState String++newtype CGIFunctor a b c = CGI (a (Input b) (Output c))++example :: (ArrowChoice a, ArrowContext a String) => CGIFunctor a b String+example = proc z -> do+		q <- ask -< "What is your question?"+		ans <- ask -< q+		returnA -< "The answer to \"" ++ q ++ "\" is " ++ ans++liftCGI :: ArrowChoice a => a b c -> CGIFunctor a b c+liftCGI f = CGI $ proc (Initial b) -> do+		c <- f -< b+		returnA -< Final c++ask :: ArrowChoice a => CGIFunctor a String String+ask = CGI $ proc x -> case x of+	Initial q -> returnA -< Suspend Ask q+	Resume Ask a -> returnA -< Final a++instance ArrowChoice a => Arrow (CGIFunctor a) where+	arr f = CGI $ proc (Initial b) ->+		returnA -< Final (f b)++	CGI f >>> CGI g = CGI $ proc z -> case z of+			Initial b -> enterf -< Initial                 b+			Resume (Comp (Left s)) a -> enterf -< Resume s a+			Resume (Comp (Right s)) a -> enterg -< Resume s a+		where	enterf = proc x -> do+				y <- f -< x+				case y of+					Final c -> enterg -< Initial c+					Suspend s q -> returnA -<+						Suspend (Comp (Left s)) q+			enterg = proc x -> do+				y <- g -< x+				returnA -< case y of+					Final d -> Final d+					Suspend s q ->+						Suspend (Comp (Right s)) q++instance (ArrowChoice a, ArrowContext a d, Read d, Show d) =>+		ArrowContext (CGIFunctor a) d where+	first (CGI f) = CGI $ proc x -> do+			let (b', d) = case x of+				Initial (b, d) -> (Initial b, d)+				Resume (First s v) a -> (Resume s a, read v)+			c' <- f -< b'+			returnA -< case c' of+				Final c -> Final (c, d)+				Suspend s q -> Suspend (First s (show d)) q+++instance ArrowChoice a => ArrowChoice (CGIFunctor a) where+	left (CGI f) = CGI $ proc x -> case x of+			Initial (Left b) -> enterf -< Initial  b+			Initial (Right d) -> returnA -< Final (Right d)+			Resume s a -> enterf -< Resume s       a+		where	enterf = proc x -> do+				y <- f -< x+				case y of+					Final c -> returnA -< Final (Left c)+					Suspend s q -> returnA -< Suspend s q
+ examples/circuits/Circuits.lhs view
@@ -0,0 +1,73 @@+> {-# OPTIONS -F -pgmF arrowp-ext #-}++{-# LANGUAGE Arrows #-}++> module Circuits where++> import Control.Arrow+> import Control.Arrow.Transformer.Automaton+> import Control.Arrow.Transformer.Stream+> import Data.Monoid+> import Data.Stream++Some simple example circuits++A resettable counter (first example in several Hawk papers):++> counter :: ArrowCircuit a => a Bool Int+> counter = proc reset -> do+>	rec	output <- returnA -< if reset then 0 else next+>		next <- delay 0 -< output+1+>	returnA -< output++Some other basic circuits from the Hawk library.++flush: when reset is True, return d for n ticks, otherwise copy value.+(a variation on the resettable counter)++> flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b+> flush n d = proc (value, reset) -> do+>	rec	count <- returnA -< if reset then n else max (next-1) 0+>		next <- delay 0 -< count+>	returnA -< if count > 0 then d else value++latch: on each tick, return the last value for which reset was True,+or init if there was none.+ +> latch :: ArrowCircuit a => b -> a (b, Bool) b+> latch init = proc (value, reset) -> do+>	rec	out <- returnA -< if reset then value else last+>		last <- delay init -< out+>	returnA -< out++Run a circuit on a partial input++> partRunAutomaton ::+>	(ArrowLoop a, ArrowApply a) => Automaton a b c -> a [b] [c]+> partRunAutomaton f = proc xs -> do+>	s <- (|runAutomaton (\x -> f -< x)|) (listToStream xs)+>	returnA -< take (length xs) (streamToList s)++> partRunStream :: ArrowLoop a => StreamArrow a b c -> a [b] [c]+> partRunStream f = proc xs -> do+>	s <- (|runStream (\x -> f -< x)|) (listToStream xs)+>	returnA -< take (length xs) (streamToList s)++Some tests using the counter++> test_input = [True, False, True, False, False, True, False, True]++A test of the resettable counter.++> ts = partRunStream counter test_input++> ta = partRunAutomaton counter test_input++A step function (cf current in Lustre)++> step :: ArrowCircuit a => b -> a (Either b c) b+> step b = proc x -> do+>		rec	last_b <- delay b -< getLeft last_b x+>		returnA -< last_b+>	where	getLeft _ (Left b) = b+>		getLeft b (Right _) = b
+ examples/powertrees/Hom.lhs view
@@ -0,0 +1,220 @@+> {-# OPTIONS -F -pgmF arrowp-ext #-}++Homogeneous (or depth-preserving) functions over perfectly balanced trees.++> module Hom where++> import Control.Arrow+> import Control.Category+> import Data.Complex+> import Prelude hiding (id, (.))++> infixr 4 :&:++Consider the following non-regular type of perfectly balanced trees,+or `powertrees' (cf Jayadev Misra's powerlists):++> data Pow a = Zero a | Succ (Pow (Pair a))+> 	deriving Show++> type Pair a = (a, a)++Here are some example elements:++> tree0 = Zero 1+> tree1 = Succ (Zero (1, 2))+> tree2 = Succ (Succ (Zero ((1, 2), (3, 4))))+> tree3 = Succ (Succ (Succ (Zero (((1, 2), (3, 4)), ((5, 6), (7, 8))))))++The elements of this type have a string of constructors expressing+a depth n as a Peano numeral, enclosing a nested pair tree of 2^n+elements.  The type definition ensures that all elements of this type+are perfectly balanced binary trees of this form.  (Such things arise+in circuit design, eg Ruby, and descriptions of parallel algorithms.)+And the type system will ensure that all legal programs preserve+this structural invariant.+ +The only problem is that the type constraint is too restrictive, rejecting+many of the standard operations on these trees.  Typically you want to+split a tree into two subtrees, do some processing on the subtrees and+combine the results.  But the type system cannot discover that the two+results are of the same depth (and thus combinable).  We need a type+that says a function preserves depth.  Here it is:++> data Hom a b = (a -> b) :&: Hom (Pair a) (Pair b)++A homogeneous (or depth-preserving) function is an infinite sequence of+functions of type Pair^n a -> Pair^n b, one for each depth n.  We can+apply a homogeneous function to a powertree by selecting the function+for the required depth:++> apply :: Hom a b -> Pow a -> Pow b+> apply (f :&: fs) (Zero x) = Zero (f x)+> apply (f :&: fs) (Succ t) = Succ (apply fs t)++Having defined apply, we can forget about powertrees and do all our+programming with Hom's.  Firstly, Hom is an arrow:+++> instance Category Hom where+>  id = id :&: id+>  (g :&: gs) . (f :&: fs) = (g . f) :&: (fs >>> gs)+>+> instance Arrow Hom where+> 	arr f = f :&: arr (f *** f)+> 	first (f :&: fs) =+> 		first f :&: (arr transpose >>> first fs >>> arr transpose)++> transpose :: ((a,b), (c,d)) -> ((a,c), (b,d))+> transpose ((a,b), (c,d)) = ((a,c), (b,d))++arr maps f over the leaves of a powertree.++The composition >>> composes sequences of functions pairwise.+ +The *** operator unriffles a powertree of pairs into a pair of powertrees,+applies the appropriate function to each and riffles the results.+It defines a categorical product for this arrow category.++When describing algorithms, one often provides a pure function for the+base case (trees of one element) and a (usually recursive) expression+for trees of pairs.++For example, a common divide-and-conquer pattern is the butterfly, where+one recursive call processes the odd-numbered elements and the other+processes the even ones (cf Geraint Jones and Mary Sheeran's Ruby papers):++> butterfly :: (Pair a -> Pair a) -> Hom a a+> butterfly f = id :&: proc (x, y) -> do+> 		x' <- butterfly f -< x+> 		y' <- butterfly f -< y+> 		returnA -< f (x', y')++The recursive calls operate on halves of the original tree, so the+recursion is well-defined.++Some examples of butterflies:++> rev :: Hom a a+> rev = butterfly swap+>	where	swap (x, y) = (y, x)++> unriffle :: Hom (Pair a) (Pair a)+> unriffle = butterfly transpose++Batcher's sorter for bitonic sequences:++> bisort :: Ord a => Hom a a+> bisort = butterfly cmp+> 	where	cmp (x, y) = (min x y, max x y)++This can be used (with rev) as the merge phase of a merge sort.+ +> sort :: Ord a => Hom a a+> sort = id :&: proc (x, y) -> do+>		x' <- sort -< x+>		y' <- sort -< y+>		yr <- rev -< y'+>		p <- unriffle -< (x', yr)+>		bisort2 -< p+>	where _ :&: bisort2 = bisort++Here is the scan operation, using the algorithm of Ladner and Fischer:++> scan :: (a -> a -> a) -> a -> Hom a a+> scan op b = id :&: proc (x, y) -> do+> 		y' <- scan op b -< op x y+> 		l <- rsh b -< y'+> 		returnA -< (op l x, y')++The auxiliary function rsh b shifts each element in the tree one place to+the right, placing b in the now-vacant leftmost position, and discarding+the old rightmost element:++> rsh :: a -> Hom a a+> rsh b = const b :&: proc (x, y) -> do+> 		w <- rsh b -< y+> 		returnA -< (w, x)++Finally, here is the Fast Fourier Transform:++> type C = Complex Double++> fft :: Hom C C+> fft = id :&: proc (x, y) -> do+> 		x' <- fft -< x+> 		y' <- fft -< y+> 		r <- roots (-1) -< ()+> 		let z = r*y'+> 		unriffle -< (x' + z, x' - z)++The auxiliary function roots r (where r is typically a root of unity)+populates a tree of size n (necessarily a power of 2) with the values+1, w, w^2, ..., w^(n-1), where w^n = r.++> roots :: C -> Hom () C+> roots r = const 1 :&: proc _ -> do+> 		x <- roots r' -< ()+> 		unriffle -< (x, x*r')+>	where	r' = if imagPart s >= 0 then -s else s+> 		s = sqrt r++Miscellaneous functions:++> rrot :: Hom a a+> rrot = id :&: proc (x, y) -> do+> 		w <- rrot -< y+> 		returnA -< (w, x)++> ilv :: Hom a a -> Hom (Pair a) (Pair a)+> ilv f = proc (x, y) -> do+> 		x' <- f -< x+> 		y' <- f -< y+> 		returnA -< (x', y')++> scan' :: (a -> a -> a) -> a -> Hom a a+> scan' op b = proc x -> do+>		l <- rsh b -< x+>		(id :&: ilv (scan' op b)) -< op l x++> riffle :: Hom (Pair a) (Pair a)+> riffle = id :&: proc ((x1, y1), (x2, y2)) -> do+>		x <- riffle -< (x1, x2)+>		y <- riffle -< (y1, y2)+>		returnA -< (x, y)++> invert :: Hom a a+> invert = id :&: proc (x, y) -> do+> 		x' <- invert -< x+> 		y' <- invert -< y+>		unriffle -< (x', y')++> carryLookaheadAdder :: Hom (Bool, Bool) Bool+> carryLookaheadAdder = proc (x, y) -> do+>		carryOut <- rsh (Just False) -<+>			if x == y then Just x else Nothing+>		Just carryIn <- scan plusMaybe Nothing -< carryOut+>		returnA -< x `xor` y `xor` carryIn+>	where	plusMaybe x Nothing = x+>		plusMaybe x (Just y) = Just y+>		False `xor` b = b+>		True `xor` b = not b++Global conditional for SIMD++> ifAll :: Hom a b -> Hom a b -> Hom (a, Bool) b+> ifAll fs gs = ifAllAux snd (arr fst >>> fs) (arr fst >>> gs)+>	where	ifAllAux :: (a -> Bool) -> Hom a b -> Hom a b -> Hom a b+>		ifAllAux p (f :&: fs) (g :&: gs) =+>			liftIf p f g :&: ifAllAux (liftAnd p) fs gs+>		liftIf p f g x = if p x then f x else g x+>		liftAnd p (x, y) = p x && p y++> maybeAll :: Hom a c -> Hom (a, b) c -> Hom (a, Maybe b) c+> maybeAll (n :&: ns) (j :&: js) =+>	choose :&: (arr dist >>> maybeAll ns (arr transpose >>> js))+>	where	choose (a, Nothing) = n a+>		choose (a, Just b) = j (a, b)+>		dist ((a1, b1), (a2, b2)) = ((a1, a2), zipMaybe b1 b2)+>		zipMaybe (Just x) (Just y) = Just (x, y)+>		zipMaybe _ _ = Nothing
src/ArrCode.hs view
@@ -187,7 +187,7 @@     toHaskellArg = Paren def . toHaskellCode  newtype Tuple = Tuple (Set (Name ()))-  deriving (Eq,Generic,Monoid,Show)+  deriving (Eq,Generic,Semigroup,Monoid,Show) instance Observable Tuple  isEmptyTuple :: Tuple -> Bool
src/ArrSyn.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -23,6 +24,7 @@ import           Data.Set                   (Set) import qualified Data.Set                   as Set import           Debug.Hoed.Pure+import           Debug.Hoed.Pure.TH import           Language.Haskell.Exts      (Alt (..), Binds (..), Decl (..),                                              Exp (), GuardedRhs (..),                                              Match (..), Name, Pat (..),@@ -30,198 +32,187 @@  import qualified Language.Haskell.Exts      as H +data TransState = TransState {+      locals  :: Set (Name ()),   -- vars in scope defined in this proc+      cmdVars :: Map (Name ()) Arrow+  } deriving (Eq, Generic, Show)++instance Observable TransState+ -- ----------------------------------------------------------------------------- -- Translation to Haskell  -- This is a 2-phase process:--- - transCmd' generates an abstract arrow combinator language represented+-- - transCmd generates an abstract arrow combinator language represented --   by the Arrow type, and -- - toHaskell turns that into Haskell. -translate :: Pat S -> Exp S -> Exp S-translate p c = H.Paren (ann c) $ toHaskell (transCmd s p' c)-      where   (s, p') = startPattern p--startPattern :: Pat S -> (TransState, Pat S)-startPattern = observe "startPattern" startPattern'--startPattern' :: Pat S -> (TransState, Pat S)-startPattern' p =-      (TransState {-              locals = definedVars p,-              cmdVars = Map.empty-       }, p)--- The pattern argument is often pseudo-recursively defined in terms of--- the context part of the result of these functions.  (It's not real--- recursion, because that part is independent of the pattern.)--transCmd :: TransState -> Pat S -> Exp S -> Arrow-transCmd = observe "transCmd" transCmd'+obs [d|+  startPattern :: Pat S -> (TransState, Pat S)+  startPattern p =+        (TransState {+                locals = definedVars p,+                cmdVars = Map.empty+        }, p)+  -- The pattern argument is often pseudo-recursively defined in terms of+  -- the context part of the result of these functions.  (It's not real+  -- recursion, because that part is independent of the pattern.) -transCmd' :: TransState -> Pat S -> Exp S -> Arrow-transCmd' s p (H.LeftArrApp _ f e)-      | Set.null (freeVars f `Set.intersection` locals s) =-              arr 0 (input s) p e >>> arrowExp f-      | otherwise =-              arr 0 (input s) p (pair f e) >>> app-transCmd' s p (H.LeftArrHighApp  l f e) = transCmd s p (H.LeftArrApp l f e)-transCmd' _ _ H.RightArrApp{} =-  error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"-transCmd' _ _ H.RightArrHighApp{} =-  error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"-transCmd' s p (H.InfixApp _ c1 op c2) =-  infixOp (transCmd s p c1) op (transCmd s p c2)-transCmd' s p (H.Let _ decls c) =-      arrLet (anonArgs a) (input s) p decls' e >>> a-      where   (s', decls') = addVars' s decls-              (e, a) = transTrimCmd s' c-transCmd' s p (H.If l e c1 c2)-  | Set.null (freeVars e `Set.intersection` locals s) =-      ifte e (transCmd s p c1) (transCmd s p c2)-  | otherwise =-      arr 0 (input s) p (H.If l e (left e1) (right e2)) >>> (a1 ||| a2)-      where   (e1, a1) = transTrimCmd s c1-              (e2, a2) = transTrimCmd s c2-transCmd' s p (H.Case l e as)-  | Set.null (freeVars e `Set.intersection` locals s) =-    Arrow {-      context = ctx,-      anonArgs = 0,-      code = H.Case (Loc l) (Loc <$> e) alts-          }-  | otherwise =-   arr 0 (input s) p (H.Case l e as') >>> foldr1 (|||) (reverse cases)-  where-    (alts, ctx) = runWriter $ flip traverseAlts (Loc <$$> as) $ \exp -> do-      let arrow = transCmd s p (getLoc <$> exp)-      tell $ context arrow-      return $ code arrow-    (as', (ncases, cases)) = runState (mapM (transAlt s) as) (0, [])-    transAlt = observeSt "transAlt" transAlt'-    transAlt' s (Alt loc p gas decls) = do-      let (s', p') = addVars' s p-          (s'', decls') = addVars' s' decls-      gas' <- transGuardedRhss s'' gas-      return (H.Alt loc p' gas' decls')-    transGuardedRhss = observeSt "transGuardedRhss" transGuardedRhss'-    transGuardedRhss' s (UnGuardedRhs l c) = do-      body <- newAlt s c-      return (H.UnGuardedRhs l body)-    transGuardedRhss' s (GuardedRhss l gas) = do-      gas' <- mapM (transGuardedRhs s) gas-      return (H.GuardedRhss l gas')-    transGuardedRhs = observeSt "transGuardedRhs" transGuardedRhs'-    transGuardedRhs' s (GuardedRhs loc e c) = do-      body <- newAlt s c-      return (H.GuardedRhs loc e body)-    newAlt = observeSt "newAlt" newAlt'-    newAlt' s c = do-      let (e, a) =-            transTrimCmd s c-      (n, as) <- get-      put (n + 1, a : as)-      return (label n e)-    label = observe "label" label'-    label' n e =-      times-        n-        right-        (if n < ncases - 1-           then left e-           else e)-transCmd' s p (H.Paren _ c) =-      transCmd s p c-transCmd' s p (H.Do _ ss) =-      transDo s p (init ss) (let Qualifier _ e = last ss in e)-transCmd' s p (H.App _ c arg) =-      anon (-1) $-      arr (anonArgs a) (input s) p (pair e arg) >>> a-      where   (e, a) = transTrimCmd s c-transCmd' s p (H.Lambda _ ps c) =-  anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c-  where-    (s', ps') = addVars' s ps-transCmd' _ _ x = error $ "Invalid parse: " ++ showSrcLoc (H.fromSrcInfo $ getSrcSpanInfo $ ann x)- where-  showSrcLoc :: H.SrcLoc -> String-  showSrcLoc (H.SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col+  transCmd :: TransState -> Pat S -> Exp S -> Arrow+  transCmd s p (H.LeftArrApp _ f e)+        | Set.null (freeVars f `Set.intersection` locals s) =+                arr 0 (input s) p' e >>> arrowExp f+        | otherwise =+                arr 0 (input s) p' (pair f e) >>> app+    where+      p' = trimPat e p --- transCmd' s p (CmdVar n) =---       arr (anonArgs a) (input s) p e >>> arrowExp (H.Var () (H.UnQual () n))---       where   Just a = Map.lookup n (cmdVars s)---               e = expTuple (context a)+  transCmd s p (H.LeftArrHighApp  l f e) = transCmd s p (H.LeftArrApp l f e)+  transCmd _ _ H.RightArrApp{} =+    error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"+  transCmd _ _ H.RightArrHighApp{} =+    error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"+  transCmd s p (H.InfixApp _ c1 op c2) =+    infixOp (transCmd s p c1) op (transCmd s p c2)+  transCmd s p (H.Let _ decls c) =+    arrLet (anonArgs a) (input s) (trimPat e p) decls' e >>> a+        where   (s', decls') = addVars s decls+                (e, a) = transTrimCmd s' c+  transCmd s p (H.If l e c1 c2)+    | Set.null (freeVars e `Set.intersection` locals s) =+        ifte e (transCmd s p c1) (transCmd s p c2)+    | otherwise =+        arr 0 (input s) p (H.If l e (left e1) (right e2)) >>> (a1 ||| a2)+        where   (e1, a1) = transTrimCmd s c1+                (e2, a2) = transTrimCmd s c2+  transCmd s p (H.Case l e as)+    | Set.null (freeVars e `Set.intersection` locals s) =+      Arrow {+        context = ctx,+        anonArgs = 0,+        code = H.Case (Loc l) (Loc <$> e) alts+            }+    | otherwise =+    arr 0 (input s) p (H.Case l e as') >>> foldr1 (|||) (reverse cases)+    where+      (alts, ctx) = runWriter $ flip traverseAlts (Loc <$$> as) $ \exp -> do+        let arrow = transCmd s p (getLoc <$> exp)+        tell $ context arrow+        return $ code arrow+      (as', (ncases, cases)) = runState (mapM (transAlt s) as) (0, [])+      transAlt = observeSt "transAlt" transAlt'+      transAlt' s (Alt loc p gas decls) = do+        let (s', p') = addVars s p+            (s'', decls') = addVars s' decls+        gas' <- transGuardedRhss s'' gas+        return (H.Alt loc p' gas' decls')+      transGuardedRhss = observeSt "transGuardedRhss" transGuardedRhss'+      transGuardedRhss' s (UnGuardedRhs l c) = do+        body <- newAlt s c+        return (H.UnGuardedRhs l body)+      transGuardedRhss' s (GuardedRhss l gas) = do+        gas' <- mapM (transGuardedRhs s) gas+        return (H.GuardedRhss l gas')+      transGuardedRhs = observeSt "transGuardedRhs" transGuardedRhs'+      transGuardedRhs' s (GuardedRhs loc e c) = do+        body <- newAlt s c+        return (H.GuardedRhs loc e body)+      newAlt = observeSt "newAlt" newAlt'+      newAlt' s c = do+        let (e, a) =+              transTrimCmd s c+        (n, as) <- get+        put (n + 1, a : as)+        return (label n e)+      label = observe "label" label'+      label' n e =+        times+          n+          right+          (if n < ncases - 1+            then left e+            else e)+  transCmd s p (H.Paren _ c) =+        transCmd s p c+  transCmd s p (H.Do _ ss) =+        transDo s p (init ss) (let Qualifier _ e = last ss in e)+  transCmd s p (H.App _ c arg) =+        anon (-1) $+        arr (anonArgs a) (input s) p (pair e arg) >>> a+        where   (e, a) = transTrimCmd s c+  transCmd s p (H.Lambda _ ps c) =+    anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c+    where+      (s', ps') = addVars s ps+  transCmd _ _ x = error $ "Invalid parse: " ++ showSrcLoc (H.fromSrcInfo $ getSrcSpanInfo $ ann x)+   where+    showSrcLoc :: H.SrcLoc -> String+    showSrcLoc (H.SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col --- Like TransCmd, but use the minimal input pattern.  The first component--- of the result is the matching expression to build this input.--- That is, the result is (e, proc p' -> c) with the minimal p' such that+  -- transCmd s p (CmdVar n) =+  --       arr (anonArgs a) (input s) p e >>> arrowExp (H.Var () (H.UnQual () n))+  --       where   Just a = Map.lookup n (cmdVars s)+  --               e = expTuple (context a) --- 	proc p -> c = arr (first^n (p -> e)) >>> (proc p' -> c)+  -- Like TransCmd, but use the minimal input pattern.  The first component+  -- of the result is the matching expression to build this input.+  -- That is, the result is (e, proc p' -> c) with the minimal p' such that --- where n is the number of anonymous arguments taken by c.-transTrimCmd :: TransState -> Exp S -> (Exp S, Arrow)-transTrimCmd = observe "transTrimCmd" transTrimCmd'-transTrimCmd' :: TransState -> Exp S -> (Exp S, Arrow)-transTrimCmd' s c = (expTuple (context a), a)-      where   a = transCmd s (patternTuple (context a)) c+  -- 	proc p -> c = arr (first^n (p -> e)) >>> (proc p' -> c) -transDo :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow-transDo = observe "transDo" transDo'+  -- where n is the number of anonymous arguments taken by c.+  transTrimCmd :: TransState -> Exp S -> (Exp S, Arrow)+  transTrimCmd s c = (expTuple (context a), a)+        where   a = transCmd s (patternTuple (context a)) c -transDo' :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow-transDo' s p [] c =-      transCmd s p c-transDo' s p (Qualifier l exp : ss) c =-  transDo' s p (Generator l (PWildCard l) exp : ss) c-transDo' s p (Generator _ pg cg:ss) c =-      if isEmptyTuple u then-        transCmd s p cg >>> transDo s' pg ss c-      else-        arr 0 (input s) p (pair eg (expTuple u)) >>> first ag u >>> a-      where   (s', pg') = addVars' s pg-              a = observe "a" $ bind (definedVars pg)-                      (transDo s' (pairP pg' (patternTuple u)) ss c)-              u = observe "u" $ context a-              (eg, ag) = transTrimCmd s cg-transDo' s p (LetStmt l decls : ss) c =-      transCmd s p (H.Let l decls (H.Do l (ss ++ [Qualifier l c])))-transDo' s p (RecStmt l rss:ss) c =-  bind-    defined-    (loop-       (transDo-          s'-          (pairP p (irrPat (patternTuple feedback)))-          rss'-          (returnCmd (pair output (expTuple feedback)))) >>>-     a)-  where-    defined = foldMap definedVars rss-    (s', rss') = addVars' s rss-    (output, a) = transTrimCmd s' (H.Do l (ss ++ [Qualifier l c]))-    feedback =-      context-        (transDo-           s'-           p-           rss'-           (returnCmd-              (foldr (pair . H.Var l . H.UnQual l) output (const def <$$> Set.toList defined)))) `intersectTuple`+  transDo :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow+  transDo s p [] c =+        transCmd s p c+  transDo s p (Qualifier l exp : ss) c =+    transDo s p (Generator l (PWildCard l) exp : ss) c+  transDo s p (Generator _ pg cg:ss) c =+        if isEmptyTuple u then+          transCmd s p cg >>> transDo s' pg ss c+        else+          arr 0 (input s) p (pair eg (expTuple u)) >>> first ag u >>> a+        where   (s', pg') = addVars s pg+                a = observe "a" $ bind (definedVars pg)+                        (transDo s' (pairP pg' (patternTuple u)) ss c)+                u = observe "u" $ context a+                (eg, ag) = transTrimCmd s cg+  transDo s p (LetStmt l decls : ss) c =+        transCmd s p (H.Let l decls (H.Do l (ss ++ [Qualifier l c])))+  transDo s p (RecStmt l rss:ss) c =+    bind       defined--data TransState = TransState {-      locals  :: Set (Name ()),   -- vars in scope defined in this proc-      cmdVars :: Map (Name ()) Arrow-  } deriving (Eq, Generic, Show)+      (loop+        (transDo+            s'+            (pairP p (irrPat (patternTuple feedback)))+            rss'+            (returnCmd (pair output (expTuple feedback)))) >>>+      a)+    where+      defined = foldMap definedVars rss+      (s', rss') = addVars s rss+      (output, a) = transTrimCmd s' (H.Do l (ss ++ [Qualifier l c]))+      feedback =+        context+          (transDo+            s'+            p+            rss'+            (returnCmd+                (foldr (pair . H.Var l . H.UnQual l) output (const def <$$> Set.toList defined)))) `intersectTuple`+        defined+ |] -instance Observable TransState+translate :: Pat S -> Exp S -> Exp S+translate p c = H.Paren (ann c) $ toHaskell (transCmd s p' c)+      where   (s, p') = startPattern p  input :: TransState -> Tuple input s = Tuple (locals s)--addVars'-  :: (Observable a, AddVars a)-  => TransState -> a -> (TransState, a)-addVars' = observe "addVars" addVars  class AddVars a where       addVars :: TransState -> a -> (TransState, a)
src/Control/Arrow/QuasiQuoter.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} module Control.Arrow.QuasiQuoter   ( proc+  , procEx   ) where  import Control.Arrow.Notation@@ -23,15 +24,15 @@ --   @  proc :: QuasiQuoter-proc = QuasiQuoter-  { quoteExp  = quote+proc = procEx defaultParseMode{extensions = defaultExtensions}++procEx :: ParseMode -> QuasiQuoter+procEx parseMode = QuasiQuoter+  { quoteExp  = quoteEx parseMode   , quotePat  = error "proc: pattern quotes not supported"   , quoteType = error "proc: type quotes not supported"   , quoteDec  = error "proc: dec quotes not supported"   }--quote :: String -> Q Exp-quote = quoteEx defaultParseMode { extensions = defaultExtensions }  quoteEx :: ParseMode -> String -> Q Exp quoteEx mode inp =
src/NewCode.hs view
@@ -34,7 +34,7 @@ getLoc (Loc s) = s getLoc other   = error $ "getLoc: " ++ show other -pattern ReturnA l = ExprHole (ReturnCode l)+pattern ReturnA l = Var OpCode (Special OpCode (ExprHole (ReturnCode l))) pattern Arr l i pat bb e = Lambda (ArrCode l i bb) [pat] e pattern Compose a bb c <- List ComposeCode ( split -> (a,bb,c) )   where
src/Utils.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLists     #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-} {-# LANGUAGE TupleSections       #-} {-# LANGUAGE TypeFamilies        #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -Wno-orphans #-}@@ -14,6 +15,7 @@   , freeVarss   , definedVars   , irrPat+  , trimPat   , left, right   , pair   , pairP@@ -44,13 +46,14 @@ import           Data.Set                      (Set) import qualified Data.Set                      as Set import           Debug.Hoed.Pure               hiding (Module)+import           Debug.Hoed.Pure.TH import           Language.Haskell.Exts import qualified Language.Haskell.Exts.Util    as HSE #ifdef DEBUG import           Language.Haskell.Exts.Observe () #endif-import SrcLocs-import NewCode+import           NewCode+import           SrcLocs  freeVars   :: ( Observable a@@ -95,16 +98,25 @@ times :: Int -> (a -> a) -> a -> a times n f x = iterate f x !! n +-- | Hide variables that don't satisfy a predicate+filterPat :: (Data a) => (Name a -> Bool) -> Pat a -> Pat a+filterPat pred = transform go where+  go p@(PVar l n)+    | pred n = p+    | otherwise = PWildCard l+  go (PAsPat _ n p)+    | not(pred n) = go p+  go x = x+ -- | Hide variables from a pattern-hidePat :: Set (Name ()) -> Pat S -> Pat S-hidePat vs = transform (go vs) where-  go vs p@(PVar l n)-    | void n `Set.member` vs = PWildCard l-    | otherwise = p-  go vs (PAsPat _ n p)-    | void n `Set.member` vs = go vs p-  go _ x = x+hidePat :: Data a => Set (Name ()) -> Pat a -> Pat a+hidePat vs = filterPat (not . (`Set.member` vs) . void) +obs [d|+  trimPat :: Exp S -> Pat S -> Pat S+  trimPat vs = filterPat ((`Set.member` freeVars vs) . void)+    |]+ pair :: Exp code -> Exp code -> Exp code pair e1 e2 = Tuple (ann e1) Boxed [e1, e2] @@ -168,6 +180,8 @@ -- Override some AST instances for comprehension instance {-# OVERLAPS #-} Observable (Exp Code) where   observer = observePretty+instance {-# OVERLAPS #-} Observable (Exp S) where+  observer = observePretty instance {-# OVERLAPS #-} Observable (Name S) where   observer = observePretty instance {-# OVERLAPS #-} Observable (QName S) where@@ -179,6 +193,8 @@   observer = observePretty instance {-# OVERLAPS #-} Observable (Pat Code) where   observer = observePretty+instance {-# OVERLAPS #-} Observable (Pat S) where+  observer = observePretty instance {-# OVERLAPS #-} Observable (QOp S) where   observer = observePretty instance {-# OVERLAPS #-} Observable (Op S) where@@ -188,6 +204,10 @@ instance {-# OVERLAPS #-} Observable (Alt S) where   observer = observePretty instance {-# OVERLAPS #-} Observable (Set (Name S)) where+  constrain = constrainBase+  observer x cxt =+    seq x $ send (between "[" "]"$ intercalate "," $ prettyPrint <$> map void (Set.toList x)) (return x) cxt+instance {-# OVERLAPS #-} Observable (Set (Name ())) where   constrain = constrainBase   observer x cxt =     seq x $ send (between "[" "]"$ intercalate "," $ prettyPrint <$> map void (Set.toList x)) (return x) cxt