arrowp-qq 0.1.1 → 0.2

raw patch · 28 files changed

+1639/−2485 lines, 28 filesdep +Hoeddep +NoHoeddep +arrowp-qqdep −haskell-srcdep ~basedep ~template-haskellnew-component:exe:arrowp-extPVP ok

version bump matches the API change (PVP)

Dependencies added: Hoed, NoHoed, arrowp-qq, arrows, data-default, haskell-src-exts, haskell-src-exts-observe, haskell-src-exts-util, haskell-src-meta, syb, uniplate

Dependencies removed: haskell-src

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• README +0/−15
• README.md +101/−0
• app/Main.hs +62/−0
• arrowp-qq.cabal +87/−11
• examples/Conditional.hs +21/−0
• examples/Main.hs +20/−0
• examples/Parser/ExprParser.lhs +91/−0
• examples/Parser/Parser.lhs +254/−0
• examples/TH/BackStateArrow.hs +39/−0
• examples/TH/TH.hs +24/−0
• examples/TH/While.hs +21/−0
• examples/small/BackStateArrow.hs +39/−0
• examples/small/Egs.hs +20/−0
• examples/small/Eval.hs +42/−0
• examples/small/Eval1.hs +45/−0
• examples/small/Lift.hs +13/−0
• examples/small/ListOps.hs +29/−0
• src/ArrCode.hs +255/−0
• src/ArrCode.lhs +0/−245
• src/ArrSyn.hs +243/−0
• src/ArrSyn.lhs +0/−304
• src/Control/Arrow/Notation.hs +23/−0
• src/Control/Arrow/QuasiQuoter.hs +23/−139
• src/Lexer.hs +0/−564
• src/Parser.ly +0/−997
• src/State.hs +0/−6
• src/Utils.hs +187/−0
• src/Utils.lhs +0/−204

@@ -1,15 +0,0 @@-A prototype quasiquoter for arrow notation packaged by Jose Iborra,-based on the arrowp preprocessor developed by Ross Paterson <ross@soi.city.ac.uk>.--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.--RUNNING THE ARROW QUASI QUOTER---addA :: Arrow a => a b Int -> a b Int -> a b Int-addA f g = [proc| x -> do-		y <- f -< x-		z <- g -< x-		returnA -< y + z |]

@@ -0,0 +1,101 @@+[![Hackage](https://img.shields.io/hackage/v/arrowp-qq.svg)](https://hackage.haskell.org/package/arrowp-qq)+[![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+==========+A preprocessor for arrow notation packaged by Jose Iborra,+based on the arrowp preprocessor 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.++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.++Status+------++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. ++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+---------------------------++```+addA :: Arrow a => a b Int -> a b Int -> a b Int+addA f g = [proc| x -> do+		y <- f -< x+		z <- g -< x+		returnA -< y + z |]+```++Using the **arrowp-ext** preprocessor+---------------------------------++```+{-# OPTIONS -F -pgmF arrowp-ext #-}+```++Comparison with **arrowp**+-----------------------+**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 (currently only if-then-else). Example:+```+proc inputs -> do+  results <- processor -< inputs+  if outputResultsArg+    then outputSink -< results+    else returnA -< ()+  returnA -< results+```+The standard **arrowp** (and GHC) desugaring for this code is:+```+  = ((processor >>> arr (\ results -> (results, results))) >>>+       (first+          (arr+             (\ results -> if outputResultsArg then Left results else Right ())+             >>> (outputSink ||| returnA))+          >>> arr (\ (_, results) -> results)))+```+This requires an `ArrowChoice`, but there is a more efficient desugaring which +performs the choice at compile time and thus an `Arrow` suffices:+```+((processor >>> arr (\ results -> (results, results))) >>>+       (first+          (if outputResultsArg then outputSink else arr (\ results -> ()))+          >>> arr (\ (_, results) -> results)))+```++Comparison with **GHC**+-----------------------+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:+```+trivial = proc inputs -> do+   chunked <- chunk -< inputs+   results <- process -< chunked+   returnA -< results+```+This code ought to desugar to a chain of arrows, and indeed, both arrowp and+arrowp-qq desugar this to:+```+trivial = chunk >>> process+```+However GHC will produce (approximately) the following code:+```+  arr(\inputs -> (inputs,inputs)) >>> first chunk >>> first process >>> arr fst+```

@@ -0,0 +1,62 @@+{-# LANGUAGE RecordWildCards #-}+module Main where++import           Control.Arrow.Notation+import           Data.List+import           Debug.Hoed.Pure+import           Language.Haskell.Exts+import           System.Environment+import           System.Exit+import           System.IO+import           Text.Printf++usage :: String -> String+usage progName = unlines [+  "usage: " ++ progName +++  " [FILENAME] [SOURCE] [DEST]",+  "Read arrow notation from SOURCE (derived from FILENAME) and write",+  "standard Haskell to DEST.",+  "If no FILENAME, use SOURCE as the original name.",+  "If no DEST or if DEST is `-', write to standard output.",+  "If no SOURCE or if SOURCE is `-', read standard input."+  ]++main :: IO ()+main = runO $ do+  args <- getArgs+  progName <- getProgName+  (orig, inp, out) <- case args of+    ["--help"] -> do+      putStrLn $ usage progName+      exitSuccess+    []     -> return ("input",Nothing,Nothing)+    [i]    -> return (i, Just i, Nothing)+    [i,o]  -> return (i, Just i, Just o)+    [orig,i,o] -> return (orig, Just i, Just o)+    _ -> do+      putStrLn $ usage progName+      error "Unrecognized set of command line arguments"+  hIn  <- maybe (return stdin)  (`openFile` ReadMode) inp+  hOut <- maybe (return stdout) (`openFile` WriteMode) out+  contents <- hGetContents hIn+  case parseFileContentsWithExts defaultExtensions contents of+        ParseFailed SrcLoc{..} err -> do+          printf "Parse error at %s:%d:%d: %s" orig srcLine srcColumn err+          exitFailure+        ParseOk x -> do+          let x' = translateModule x+          hPutStr hOut $ prettyPrintWithMode defaultMode{linePragmas=True} x'+          hClose hOut++defaultExtensions :: [Extension]+defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions++badExtensions :: [KnownExtension]+badExtensions =+    [TransformListComp -- steals the group keyword+    ,XmlSyntax, RegularPatterns -- steals a-b+    ,UnboxedTuples -- breaks (#) lens operator+    ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+    ,DoRec, RecursiveDo -- breaks rec+    ,TypeApplications -- HSE fails on @ patterns+    ]

@@ -1,24 +1,100 @@ Name:           arrowp-qq-Version:        0.1.1+Version:        0.2 Cabal-Version:  >= 1.20 Build-Type:     Simple License:        GPL License-File:   LICENCE Author:         Jose Iborra <pepeiborra@gmail.com> Maintainer:     Jose Iborra <pepeiborra@gmail.com>-Homepage:       http://www.haskell.org/arrows/+Homepage:       https://github.com/pepeiborra/arrowp Category:       Development-Synopsis:       quasiquoter translating arrow notation into Haskell 98-Description:    A quasiquoter built on top of the arrowp package.-Extra-Source-Files: README+Synopsis:       A preprocessor and quasiquoter for translating arrow notation+Description:    A suite of preprocessor and quasiquoter to desugar arrow notation built on top of Ross Paterson's arrowp and the venerable haskell-src-exts.+Extra-Source-Files: README.md +Flag Debug+  Description:         Enabled Hoed algorithmic debugging+  Default:             False+  Manual:              True++Flag TestExamples+  Description:         Build the examples using the preprocessor and quasiquoter+  Default: False+  Manual: True               ++Source-Repository head+    Type: git +    Location: http://github.com/pepeiborra/arrowp+ Library-    Exposed-Modules:     Control.Arrow.QuasiQuoter-    Build-Depends: base < 5, array, containers, haskell-src, template-haskell < 2.13, transformers+    Exposed-Modules:     +                         Control.Arrow.Notation,+                         Control.Arrow.QuasiQuoter+    Build-Depends: base < 5,+                   array,+                   containers,+                   data-default,+                   haskell-src-exts,+                   haskell-src-exts-util,+                   haskell-src-meta,+                   syb,+                   template-haskell < 2.13, +                   transformers,+                   uniplate+    if flag(Debug)+       Build-Depends:       Hoed, haskell-src-exts-observe+       cpp-options:         -DDEBUG+    else+       Build-Depends:       NoHoed+     Hs-Source-Dirs: src-    Other-Modules:  ArrCode ArrSyn Lexer Parser Parser State Utils+    Other-Modules:  ArrCode ArrSyn Utils     Default-Language:    Haskell2010 -Source-Repository head-    Type: darcs-    Location: http://github.com/pepeiborra/arrowp+executable arrowp-ext+  buildable: True+  main-is: Main.hs+  hs-source-dirs:+      app+  build-depends:+                base >= 4.7 && < 5, +                arrowp-qq,+                haskell-src-exts+  if flag(Debug)+      Build-Depends:       Hoed+      cpp-options:         -DDEBUG+  else+      Build-Depends:       NoHoed++  default-language: Haskell2010++test-suite examples+  if flag(TestExamples)+     buildable: True+  else+     buildable:  False+  type:                exitcode-stdio-1.0+  hs-source-dirs:+                 examples,+                 examples/cgi,+                 examples/circuits,+                 examples/Parser,+                 examples/powertrees,+                 examples/small+  main-is:             Main.hs+  other-modules:       +                       Parser,+                       ExprParser,+                       BackStateArrow,+                       Conditional,+                       ListOps,+                       Egs,+                       Eval,+                       Eval1,+                       Lift,+                       ListOps,+                       TH.TH,+                       TH.While,+                       TH.BackStateArrow+  build-depends:+    base, arrows, arrowp-qq, template-haskell

@@ -0,0 +1,21 @@+{- LANGUAGE Arrows -}+{-# OPTIONS -F -pgmF arrowp-ext #-}++module Conditional where++import           Control.Arrow++-- An Arrow command for use with banana brackets?+static :: Arrow a => Bool -> a b c -> a b d -> a (c,d) c -> a b c+static use abc abd adc = proc b -> do+  c <- abc -< b+  res <- if use -- :: a (b,c) c+     then do -- :: a (b,c) c+       d <- abd -< b+       adc -< (c,d)+     else returnA -< c -- :: a (b,c) c+  returnA -< res++simple :: Bool -> a b c -> a b c+simple use abc = proc b -> do+  if use then abc -< b else abc -< b

@@ -0,0 +1,20 @@+module Main where++import           BackstateArrow    ()+import           CGI               ()+-- import           Circuits          () -- Uses banana brackets+import           Conditional       ()+import           Egs               ()+import           Eval              ()+import           Eval1             ()+import           ExprParser        ()+import           Hom               ()+import           Lift              ()+import           ListOps           ()+import           TH.TH             ()+import           TH.BackstateArrow ()+import           TH.While          ()+++main :: IO ()+main = return ()

@@ -0,0 +1,91 @@+> {-# OPTIONS -F -pgmF arrowp-ext #-}+> module ExprParser where++> import Data.Char++> import Control.Arrow+> import Control.Arrow.Transformer.Error++> import Parser++Expressions++> data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown | EOF+>	deriving (Show, Eq, Ord)++> instance Symbol ESym where+>	eof = EOF++> type ExprParser = Parser ESym String (->)+> type ExprSym = Sym ESym String++The grammar++> expr :: ExprParser () Int+> expr = proc () -> do+>		x <- term -< ()+>		expr' -< x++> expr' :: ExprParser Int Int+> expr' = proc x -> do+>		returnA -< x+>	<+> do+>		symbol Plus -< ()+>		y <- term -< ()+>		expr' -< x + y+>	<+> do+>		symbol Minus -< ()+>		y <- term -< ()+>		expr' -< x - y++> term :: ExprParser () Int+> term = proc () -> do+>		x <- factor -< ()+>		term' -< x++> term' :: ExprParser Int Int+> term' = proc x -> do+>		returnA -< x+>	<+> do+>		symbol Mult -< ()+>		y <- factor -< ()+>		term' -< x * y+>	<+> do+>		symbol Div -< ()+>		y <- factor -< ()+>		term' -< x `div` y++> factor :: ExprParser () Int+> factor = proc () -> do+>		v <- symbol Number -< ()+>		returnA -< read v::Int+>	<+> do+>		symbol Minus -< ()+>		v <- factor -< ()+>		returnA -< -v+>	<+> do+>		symbol LPar -< ()+>		v <- expr -< ()+>		symbol RPar -< ()+>		returnA -< v++Lexical analysis++> lexer :: String -> [ExprSym]+> lexer [] = []+> lexer ('(':cs) = Sym LPar "(":lexer cs+> lexer (')':cs) = Sym RPar ")":lexer cs+> lexer ('+':cs) = Sym Plus "+":lexer cs+> lexer ('-':cs) = Sym Minus "-":lexer cs+> lexer ('*':cs) = Sym Mult "*":lexer cs+> lexer ('/':cs) = Sym Div "/":lexer cs+> lexer (c:cs)+>	| isSpace c = lexer cs+>	| isDigit c = Sym Number (c:w):lexer cs'+>	| otherwise = Sym Unknown [c]:lexer cs+>		where (w,cs') = span isDigit cs++> run parser = runError (runParser parser)+>	(\(_, err) -> error ("parse error: " ++ err)) . lexer++> t = run expr

@@ -0,0 +1,254 @@+> {-# OPTIONS -F -pgmF arrowp-ext #-}++LL(1) parser combinators: an arrow-ized (and greatly cut-down) version+of those of "Deterministic, Error-Correcting Combinator Parsers", by+Swierstra and Duponcheel.  This version uses statically constructed+parse tables, but doesn't do error correction.++> module Parser(+>	Symbol(eof), Sym(Sym),+>	Parser, symbol, runParser+> ) where++> import Control.Arrow+> import Control.Arrow.Operations+> import Control.Arrow.Transformer+> import Control.Arrow.Transformer.Error+> import Control.Arrow.Transformer.State+> import Control.Arrow.Transformer.Static+> import Control.Category+> import Prelude hiding (id, (.))++We require a symbol for EOF, distinguished from all existing symbols:++> class (Ord s, Show s) => Symbol s where+>	eof :: s++Combine a token with other information++> data Sym s v = Sym s v++> token (Sym s _) = s+> value (Sym _ v) = v++> instance (Show s, Show v) => Show (Sym s v) where+>	showsPrec p (Sym s v) = showParen True+>		(shows s . showString ", " . shows v)++> eofSym :: Symbol s => Sym s v+> eofSym = Sym s (error (show s ++ " has no value"))+>	where	s = eof++A dynamic parser may fail or transform a list of symbols.++> type DynamicParser s v a = StateArrow [Sym s v] (ErrorArrow String a)++> liftDynamic :: ArrowChoice a => a b c -> DynamicParser s v a b c+> liftDynamic f = lift (lift f)++The auxilliary definitions fetchHead and advance, with their explicit+type signatures, are needed to avoid nasty type errors.++> fetchHead :: ArrowChoice a => DynamicParser s v a b (Sym s v)+> fetchHead = proc _ -> do+>		(s:_) <- fetch -< ()+>		returnA -< s++> getToken :: ArrowChoice a => DynamicParser s v a b s+> getToken = fetchHead >>> arr token++> advance :: ArrowChoice a => DynamicParser s v a b (Sym s v)+> advance = proc _ -> do+>		(s:ss) <- fetch -< ()+>		store -< ss+>		returnA -< s++The dynamic symbol parser ignores the symbol, as it will already have+been checked by the table lookup.++> unitDP :: ArrowChoice a => DynamicParser s v a b v+> unitDP = advance >>> arr value++Use the static information to construct a dynamic parser.++If the table is empty, we know statically that any lookup will fail.++> mkDynamic :: (Symbol s, ArrowChoice a) =>+>	Maybe (a b c) -> Table s (DynamicParser s v a b c) ->+>		DynamicParser s v a b c+> mkDynamic Nothing t = arr id &&& getToken >>> lookupTable t err+>	where	err = proc _ -> raise -< "expected " ++ show (keys t)+> mkDynamic (Just f) t+>	| isEmptyTable t = liftDynamic f+>	| otherwise = arr id &&& getToken >>> lookupTable t base+>	where	base = proc (b, _) -> liftDynamic f -< b++If a parser arrow can recognize the empty string, it needs a function+to transform input to output.++> data Parser s v a b c = SP {+>		emptyP :: StaticMonadArrow Maybe a b c,+>		table :: Table s (DynamicParser s v a b c),+>		dynamic :: DynamicParser s v a b c+>				-- dynamic = mkDynamic empty table+>	}++> mkParser :: (Symbol s, ArrowChoice a) =>+>	StaticMonadArrow Maybe a b c -> Table s (DynamicParser s v a b c) ->+>		Parser s v a b c+> mkParser e t = SP {+>		emptyP = e,+>		table = t,+>		dynamic = mkDynamic (unwrapM e) t+>	}++> symbol :: (Symbol s, ArrowChoice a) => s -> Parser s v a b v+> symbol s = mkParser (wrapM Nothing) (unitTable s unitDP)++> eofParser :: (Symbol s, ArrowChoice a) => Parser s v a b b+> eofParser = proc x -> do+>	symbol eof -< ()+>	returnA -< x++> instance (Symbol s, ArrowChoice a) => Arrow (Parser s v a) where+>	arr f = mkParser (arr f) emptyTable+>	first (SP{emptyP = e, table = t}) =+>		mkParser (first e) (fmap first t)++> instance (Symbol s, ArrowChoice a) => Category (Parser s v a) where+>       id = arr id+>	~SP{emptyP = e2, table = t2, dynamic = d2} . SP{emptyP = e1, table = t1} =+>		if isEmptyTable common+>		then mkParser (e1 >>> e2) (plusTable t1' t2')+>		else error ("parse conflict (concatenation) on " +++>				show (keys common))+>		where	common = intersectTable t1' t2'+>			t1' = fmap (>>> d2) t1+>			t2' = seqEmptyTable (unwrapM e1) t2+>			seqEmptyTable Nothing _ = emptyTable+>			seqEmptyTable (Just f) t = fmap (liftDynamic f >>>) t++> instance (Symbol s, ArrowChoice a) => ArrowZero (Parser s v a) where+>	zeroArrow = mkParser (wrapM Nothing) emptyTable++> instance (Symbol s, ArrowChoice a) => ArrowPlus (Parser s v a) where+>	SP{emptyP = e1, table = t1} <+> SP{emptyP = e2, table = t2} =+>		if isEmptyTable common+>		then mkParser (wrapM (plusEmpty (unwrapM e1) (unwrapM e2)))+>			      (plusTable t1 t2)+>		else error ("parse conflict (union) on " ++ show (keys common))+>		where	common = intersectTable t1 t2+>			plusEmpty Nothing e2 = e2+>			plusEmpty e1 Nothing = e1+>			plusEmpty _ _ = error "Empty-Empty"++> instance (Symbol s, ArrowChoice a, ArrowLoop a) =>+>		ArrowLoop (Parser s v a) where+>	loop (SP{emptyP = e, table = t}) =+>		mkParser (wrapM (fmap loop (unwrapM e))) (fmap loop t)++Run a parser on a complete input++> runParser :: (Symbol s, ArrowChoice a) =>+>	Parser s v a () b -> ErrorArrow String a [Sym s v] b+> runParser p = proc ss -> do+>			(v, _) <- rp -< ((), ss ++ [eofSym])+>			returnA -< v+>		where	rp = runState (dynamic (p >>> eofParser))++general combinators++> option :: ArrowPlus a => (b -> c) -> a b c -> a b c+> option f p = arr f <+> p++> many :: ArrowPlus a => a b c -> a b [c]+> many p = option (const []) (some p)++> some :: ArrowPlus a => a b c -> a b [c]+> some p = some_p+>	where	some_p = proc b -> do+>			c <- p -< b+>			cs <- many_p -< b+>			returnA -< c:cs+>		many_p = option (const []) (some_p)++A different design:++> optional :: ArrowPlus a => a b b -> a b b+> optional p = arr id <+> p++> star :: ArrowPlus a => a b b -> a b b+> star p = p' where p' = optional (p >>> p')++> plus :: ArrowPlus a => a b b -> a b b+> plus p = p' where p' = p >>> optional p'++Tables.++During parser construction, these are represented as lists of pairs,+ordered by the key.  Then these are transformed into balanced search+trees for use in parsing.++> newtype Table k v = Table [(k, v)]++> emptyTable :: Table k v+> emptyTable = Table []++> unitTable :: k -> v -> Table k v+> unitTable k v = Table [(k, v)]++> instance Functor (Table k) where+>	fmap f (Table kvs) = Table [(k, f v) | (k, v) <- kvs]++Combine two tables.  In case of conflicts, the first takes precedence.++> plusTable :: Ord k => Table k v -> Table k v -> Table k v+> plusTable (Table t1) (Table t2) = Table (merge t1 t2)+>	where	merge [] kvs2 = kvs2+>		merge kvs1 [] = kvs1+>		merge (kvs1@(p1@(k1, _):kvs1')) (kvs2@(p2@(k2, _):kvs2')) =+>			case compare k1 k2 of+>			LT -> p1:merge kvs1' kvs2+>			EQ -> p1:merge kvs1' kvs2'+>			GT -> p2:merge kvs1 kvs2'++> intersectTable :: Ord k => Table k v1 -> Table k v2 -> Table k (v1, v2)+> intersectTable (Table t1) (Table t2) = Table (merge t1 t2)+>	where	merge [] _ = []+>		merge _ [] = []+>		merge (kvs1@((k1, v1):kvs1')) (kvs2@((k2, v2):kvs2')) =+>			case compare k1 k2 of+>			LT -> merge kvs1' kvs2+>			EQ -> (k1, (v1, v2)):merge kvs1' kvs2'+>			GT -> merge kvs1 kvs2'++> isEmptyTable :: Table k v -> Bool+> isEmptyTable (Table t) = null t++> keys :: Table k v -> [k]+> keys (Table kvs) = map fst kvs++> data SearchTree k v = Empty | Node (SearchTree k v) k v (SearchTree k v)++Make a balanced search tree from a table++> searchTree :: Ord k => Table k v -> SearchTree k v+> searchTree (Table kvs) = fst (mkTree (length kvs) kvs)+>	where	mkTree :: Int -> [(k,v)] -> (SearchTree k v, [(k,v)])+>		mkTree n kvs = if n == 0 then (Empty, kvs)+>			else	let	size_l = (n-1) `div` 2+>					(l, (k, v):kvs') = mkTree size_l kvs+>					(r, kvs'') = mkTree (n-1-size_l) kvs'+>				in (Node l k v r, kvs'')++Construct an arrow that searches for dynamic inputs in the statically+constructed tree of arrows.++> lookupTable :: (ArrowChoice a, Ord k) =>+>	Table k (a b c) -> a (b, k) c -> a (b, k) c+> lookupTable t def = look (searchTree t)+>	where	look Empty = def+>		look (Node l k a r) = proc (v, x) -> case compare x k of+>			LT -> look l -< (v, x)+>			EQ -> a -< v+>			GT -> look r -< (v, x)

@@ -0,0 +1,39 @@+{-# LANGUAGE QuasiQuotes #-}+module TH.BackstateArrow where++import           Control.Arrow+import           Control.Arrow.QuasiQuoter+import           Control.Category+import           Prelude                   hiding (id, (.))++-- Generalizing the backwards state transformer monad mentioned+-- in Wadler's "The Essence of Functional Programming"++newtype BackStateArrow s a b c = BST (a (b,s) (c,s))++instance ArrowLoop a => Category (BackStateArrow s a) where+	BST g . BST f = BST $ [proc| (b, s) -> do+			rec	(c, s'') <- f -< (b, s')+				(d, s') <- g -< (c, s)+			returnA -< (d, s'')|]++instance ArrowLoop a => Arrow (BackStateArrow s a) where+	arr f = BST [proc| (b, s) ->+			returnA -< (f b, s)|]+	first (BST f) = BST $ [proc| ((b, d), s) -> do+			(c, s') <- f -< (b, s)+			returnA -< ((c, d), s')|]++instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where+	left (BST f) = BST $ [proc| (x, s) ->+		case x of+			Left b -> do+				(c, s') <- f -< (b, s)+				returnA -< (Left c, s')+			Right d ->+				returnA -< (Right d, s) |]++instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where+	loop (BST f) = BST $  [proc| (b, s) -> do+			rec	((c, d), s') <- f -< ((b, d), s)+			returnA -< (c, s') |]

@@ -0,0 +1,24 @@+{-# LANGUAGE Arrows      #-}+{-# LANGUAGE QuasiQuotes #-}+module TH.TH where+import           Control.Arrow+import           Control.Arrow.QuasiQuoter+import           Language.Haskell.TH++while :: ArrowChoice a => a b Bool -> a b () -> a b ()+while p s = proc x -> do+		b <- p -< x+		if b then do+				s -< x+				while p s -< x+			else+				returnA -< ()++test p s = [proc| x -> do+		b <- p -< x+		if b then do+				s -< x+				while p s -< x+			else+				returnA -< ()+            |]

@@ -0,0 +1,21 @@+{-# LANGUAGE QuasiQuotes #-}+module TH.While where++import           Control.Arrow+import           Control.Arrow.QuasiQuoter++addA :: Arrow a => a b Int -> a b Int -> a b Int+addA f g = [proc| x -> do+		y <- f -< x+		z <- g -< x+		returnA -< y + z |]++while :: ArrowChoice a => a b Bool -> a b () -> a b ()+while p s = [proc| x -> do+		b <- p -< x+		if b then do+				s -< x+				while p s -< x+			else+				returnA -< ()+              |]

@@ -0,0 +1,39 @@+{- LANGUAGE Arrows -}+{-# OPTIONS -F -pgmF arrowp-ext #-}+module BackstateArrow where++import           Control.Arrow+import           Control.Category+import           Prelude          hiding (id, (.))++-- Generalizing the backwards state transformer monad mentioned+-- in Wadler's "The Essence of Functional Programming"++newtype BackStateArrow s a b c = BST (a (b,s) (c,s))++instance ArrowLoop a => Category (BackStateArrow s a) where+	BST g . BST f = BST $ proc (b, s) -> do+			rec	(c, s'') <- f -< (b, s')+				(d, s') <- g -< (c, s)+			returnA -< (d, s'')++instance ArrowLoop a => Arrow (BackStateArrow s a) where+	arr f = BST $ proc (b, s) ->+			returnA -< (f b, s)+	first (BST f) = BST $ proc ((b, d), s) -> do+			(c, s') <- f -< (b, s)+			returnA -< ((c, d), s')++instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where+	left (BST f) = BST $ proc (x, s) ->+		case x of+			Left b -> do+				(c, s') <- f -< (b, s)+				returnA -< (Left c, s')+			Right d ->+				returnA -< (Right d, s)++instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where+	loop (BST f) = BST $ proc (b, s) -> do+			rec	((c, d), s') <- f -< ((b, d), s)+			returnA -< (c, s')

@@ -0,0 +1,20 @@+{- LANGUAGE Arrows -}+{-# OPTIONS -F -pgmF arrowp-ext #-}+module Egs where++import           Control.Arrow++addA :: Arrow a => a b Int -> a b Int -> a b Int+addA f g = proc x -> do+		y <- f -< x+		z <- g -< x+		returnA -< y + z++while :: ArrowChoice a => a b Bool -> a b () -> a b ()+while p s = proc x -> do+		b <- p -< x+		if b then do+				s -< x+				while p s -< x+			else+				returnA -< ()

@@ -0,0 +1,42 @@+{- LANGUAGE Arrows -}+{-# OPTIONS -F -pgmF arrowp-ext #-}+module Eval where++-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5)++import           Control.Arrow+import           Data.Maybe    (fromJust)++type Id = String+data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a))+data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp++eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a)+eval (Var s) = proc env ->+		returnA -< fromJust (lookup s env)+eval (Add e1 e2) = proc env -> do+		~(Num u) <- eval e1 -< env+		~(Num v) <- eval e2 -< env+		returnA -< Num (u + v)+eval (If e1 e2 e3) = proc env -> do+		~(Bl b) <- eval e1 -< env+		if b	then eval e2 -< env+			else eval e3 -< env+eval (Lam x e) = proc env ->+		returnA -< Fun (proc v -> eval e -< (x,v):env)+eval (App e1 e2) = proc env -> do+		~(Fun f) <- eval e1 -< env+		v <- eval e2 -<< env+		f -< v++-- some tests++i = Lam "x" (Var "x")+k = Lam "x" (Lam "y" (Var "x"))+double = Lam "x" (Add (Var "x") (Var "x"))++t = n+	where Num n = eval (If (Var "b")+			(App (App k (App double (Var "x"))) (Var "x"))+			(Add (Var "x") (Add (Var "x") (Var "x"))))+		[("b", Bl True), ("x", Num 5)]

@@ -0,0 +1,45 @@+{- LANGUAGE Arrows -}+{-# OPTIONS -F -pgmF arrowp-ext #-}+module Eval1 where++-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5)++import           Control.Arrow+import           Data.Maybe    (fromJust)++type Id = String+data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a))+data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp++eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a)+eval (Var s) = proc env ->+		returnA -< fromJust (lookup s env)+eval (Add e1 e2) = proc env ->+		(eval e1 -< env) `bind` \ ~(Num u) ->+		(eval e2 -< env) `bind` \ ~(Num v) ->+		returnA -< Num (u + v)+eval (If e1 e2 e3) = proc env ->+		(eval e1 -< env) `bind` \ ~(Bl b) ->+		if b then eval e2 -< env+			else eval e3 -< env+eval (Lam x e) = proc env ->+		returnA -< Fun (proc v -> eval e -< (x,v):env)+eval (App e1 e2) = proc env ->+		(eval e1 -< env) `bind` \ ~(Fun f) ->+		(eval e2 -< env) `bind` \ v ->+		f -< v++bind :: Arrow a => a b c -> a (b,c) d -> a b d+e `bind` f = returnA &&& e >>> f++-- some tests++i = Lam "x" (Var "x")+k = Lam "x" (Lam "y" (Var "x"))+double = Lam "x" (Add (Var "x") (Var "x"))++t = n+	where Num n = eval (If (Var "b")+			(App (App k (App double (Var "x"))) (Var "x"))+			(Add (Var "x") (Add (Var "x") (Var "x"))))+		[("b", Bl True), ("x", Num 5)]

@@ -0,0 +1,13 @@+{- LANGUAGE Arrows -}+{-# OPTIONS -F -pgmF arrowp-ext #-}+module Lift where++import           Control.Arrow++-- lifting a binary operation to arrows (Hughes's paper, s4.1)++liftA2' :: Arrow a => (b -> c -> d) -> a e b -> a e c -> a e d+liftA2' op f g = proc x -> do+		y <- f -< x+		z <- g -< x+		returnA -< y `op` z

@@ -0,0 +1,29 @@+{- LANGUAGE Arrows -}+{-# OPTIONS -F -pgmF arrowp-ext #-}+module ListOps where++-- generalizing map and filter to arrows++-- Note that these need ArrowChoice (because they use case) but+-- not ArrowApply (because the arrows used before -< don't involve+-- variables defined inside the arrow abstraction).++import           Control.Arrow++mapA :: ArrowChoice a => a (b, c) d -> a (b, [c]) [d]+mapA f = proc (env, xs) -> case xs of+		[] ->+			returnA -< []+		x:xs -> do+			y <- f -< (env, x)+			ys <- mapA f -< (env, xs)+			returnA -< y:ys++filterA :: ArrowChoice a => a (b, c) Bool -> a (b, [c]) [c]+filterA p = proc (env, xs) -> case xs of+		[] ->+			returnA -< []+		x:xs -> do+			b <- p -< (env, x)+			ys <- filterA p -< (env, xs)+			returnA -< if b then x:ys else ys

@@ -0,0 +1,255 @@+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE OverloadedLists      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module ArrCode (+      Arrow,+      bind, anon,+      arr, arrLet, (>>>), arrowExp, applyOp, infixOp, (|||), first,+      VarDecl(VarDecl), letCmd,+      context, anonArgs, toHaskell,+      Tuple(..),+      isEmptyTuple, unionTuple, minusTuple, intersectTuple,+      patternTuple, expTuple,+      returnA_exp, arr_exp, compose_op, choice_op, first_exp,+      left_exp, right_exp, app_exp, loop_exp,+      ifte, app, loop, returnA+      ) where+import           Data.Default+import           Data.Set                     (Set)+import qualified Data.Set                     as Set+import           Debug.Hoed.Pure+import           Language.Haskell.Exts.Syntax hiding (Let, Tuple)+import qualified Language.Haskell.Exts.Syntax as H+import           Utils++data Arrow = Arrow+  { context  :: Tuple -- named input components used by the arrow+  , anonArgs :: Int     -- number of unnamed arguments+  , code     :: Code+  }+  deriving (Eq, Generic, Show)++instance Located Arrow  where+  type LocType Arrow = S+  location f (Arrow context anon code)=+    Arrow <$> location f context <*> pure anon <*> location f code++instance Observable Arrow++data VarDecl a = VarDecl (Name S) a+      deriving (Functor, Generic)++instance (Located a, LocType a ~ S) => Located (VarDecl a) where+  type LocType (VarDecl a) = S+  location f (VarDecl n a) = VarDecl <$> location f n <*> location f a++-- required Undecidable instances+deriving instance (Eq a) => Eq (VarDecl a)+deriving instance (Show a) => Show (VarDecl a)++instance Observable a => Observable (VarDecl a)++data Code+      = ReturnA                       -- returnA = arr id+      | Arr Int (Pat S) [Binding] (Exp S)   -- arr (first^n (\p -> ... e))+      | Compose Code [Code] Code  -- composition of 2 or more elts+      | Op (Exp S) [Code]         -- combinator applied to arrows+      | InfixOp Code (QOp S) Code+      | Let [VarDecl Code] Code+      | Ifte (Exp S) Code Code+  deriving (Eq, Generic, Show)++instance Located Code where+  type LocType Code = S+  location _ ReturnA = pure ReturnA+  location f (Arr i pat bb e) =+    Arr i <$> location f pat <*> location f bb <*> location f e+  location f (Compose c1 cc c2) =+    Compose <$> location f c1 <*> location f cc <*> location f c2+  location f (Op e cc) = Op <$> location f e <*> location f cc+  location f (InfixOp c qop c') = InfixOp <$> location f c <*> location f qop <*> location f c'+  location f (Let vv c) = Let <$> location f vv <*> location f c+  location f (Ifte e c1 c2) = Ifte <$> location f e <*> location f c1 <*> location f c2++instance Observable Code++data Binding = BindLet (Binds S) | BindCase (Pat S) (Exp S)+  deriving (Eq,Generic, Show)+instance Observable Binding++instance Located Binding where+  type LocType Binding = S+  location f (BindLet b) = BindLet <$> location f b+  location f (BindCase p e) = BindCase <$> location f p <*> location f e++loop :: Arrow -> Arrow+loop f = applyOp loop_exp [f]++app, returnA :: Arrow+app = arrowExp app_exp+returnA = arrowExp returnA_exp++bind :: Set (Name S) -> Arrow -> Arrow+bind = observe "bind" $ \vars a -> a {context = context a `minusTuple` vars}+anon :: Int -> Arrow -> Arrow+anon anonCount a = a {anonArgs = anonArgs a + anonCount}+arr+  :: Int -> Tuple -> Pat S -> Exp S -> Arrow+arr = observe "arr" $ \anons t p e ->+  Arrow+  { code =+      if same p e+        then ReturnA+        else Arr anons p [] e+  , context = t `intersectTuple` freeVars e+  , anonArgs = anons+  }+arrLet :: Int -> Tuple -> Pat S -> Binds S -> Exp S -> Arrow+arrLet anons t p ds e =+  Arrow+  { code = Arr anons p [BindLet ds] e+  , context = t `intersectTuple` vs+  , anonArgs = anons+  }+  where+    vs =+      (freeVars e `Set.union` freeVarss ds) `Set.difference` definedVars ds+ifte :: Exp S -> Arrow -> Arrow -> Arrow+ifte c th el =+  Arrow+  { code = Ifte c (code th) (code el)+  , context = context th `unionTuple` context el+  , anonArgs = 0+  }+(>>>) :: Arrow -> Arrow -> Arrow+a1 >>> a2 = a1 { code = compose (code a1) (code a2) }+arrowExp :: Exp S -> Arrow+arrowExp e =+  Arrow+  { code =+      if e == returnA_exp+        then ReturnA+        else Op e []+  , context = emptyTuple+  , anonArgs = 0+  }+applyOp :: Exp S -> [Arrow] -> Arrow+applyOp e as =+  Arrow+  { code = Op e (map code as)+  , context = foldr (unionTuple . context) emptyTuple as+  , anonArgs = 0 -- BUG: see below+  }++infixOp :: Arrow -> QOp S -> Arrow -> Arrow+infixOp a1 op a2 =+  Arrow+  { code = InfixOp (code a1) op (code a2)+  , context = context a1 `unionTuple` context a2+  , anonArgs = 0 -- BUG: as above+  }+first :: Arrow -> Tuple -> Arrow+first a ps =+  Arrow+  { code = Op first_exp [code a]+  , context = context a `unionTuple` ps+  , anonArgs = 0+  }+(|||) :: Arrow -> Arrow -> Arrow+a1 ||| a2 =+  Arrow+  { code = InfixOp (code a1) choice_op (code a2)+  , context = context a1 `unionTuple` context a2+  , anonArgs = 0+  }+letCmd :: [VarDecl Arrow] -> Arrow -> Arrow+letCmd defs a =+  Arrow+  { code = Let (map (fmap code) defs) (code a)+  , context = context a+  , anonArgs = anonArgs a+  }++compose :: Code -> Code -> Code+compose = observe "compose" compose'++compose' :: Code -> Code -> Code+compose' ReturnA a = a+compose' a ReturnA = a+compose' a1@(Arr n1 p1 ds1 e1) a2@(Arr n2 p2 ds2 e2)+  | n1 /= n2 = Compose a1 [] a2 -- could do better, but can this arise?+  | same p2 e1 = Arr n1 p1 (ds1 ++ ds2) e2+  | otherwise = Arr n1 p1 (ds1 ++ BindCase p2 e1 : ds2) e2+compose' (Compose f1 as1 g1) (Compose f2 as2 g2) =+  Compose f1 (as1 ++ (g1 : f2 : as2)) g2+compose' a (Compose f bs g) = Compose (compose a f) bs g+compose' (Compose f as g) b = Compose f as (compose g b)+compose' a1 a2 = Compose a1 [] a2++toHaskell :: Arrow -> Exp S+toHaskell = rebracket1 . toHaskellCode . code+  where+    toHaskellCode :: Code -> Exp S+    toHaskellCode ReturnA = returnA_exp+    toHaskellCode (Arr n p bs e) =+      App def arr_exp (times n (Paren def . App def first_exp) body)+      where+        body = Lambda def [p] (foldr addBinding e bs)+        addBinding (BindLet ds) e = H.Let def ds e+        addBinding (BindCase p e) e' =+          Case def e [Alt def p (UnGuardedRhs def e') Nothing]+    toHaskellCode (Compose f as g) =+      foldr (comp . toHaskellArg) (toHaskellArg g) (f : as)+      where+        comp f = InfixApp def f compose_op+    toHaskellCode (Op op as) = foldl (App def) op (map (Paren def . toHaskellCode) as)+    toHaskellCode (InfixOp a1 op a2) =+      InfixApp def (toHaskellArg a1) op (toHaskellArg a2)+    toHaskellCode (Let nas a) =+      H.Let def (BDecls def $ map toHaskellDecl nas) (toHaskellCode a)+      where+        toHaskellDecl (VarDecl n a) =+          PatBind def (PVar def n) (UnGuardedRhs def (toHaskellCode a)) Nothing+    toHaskellCode (Ifte cond th el) = If def cond (toHaskellCode th) (toHaskellCode el)++    toHaskellArg = Paren def . toHaskellCode++newtype Tuple = Tuple (Set (Name S))+  deriving (Eq,Generic,Show)+instance Observable Tuple++instance Located Tuple where+  type LocType Tuple = S+  location f (Tuple names) = Tuple <$> location f names++isEmptyTuple :: Tuple -> Bool+isEmptyTuple (Tuple t) = Set.null t++patternTuple :: Tuple -> Pat S+patternTuple (Tuple [])  = PApp def (unit_con_name def) []+patternTuple (Tuple [x]) = PVar def x+patternTuple (Tuple t)   = PTuple def Boxed (map (PVar def) (Set.toList t))++expTuple :: Tuple -> Exp S+expTuple (Tuple [])  = unit_con def+expTuple (Tuple [t]) = Var def $ UnQual def t+expTuple (Tuple t)   = H.Tuple def Boxed (map (Var def . UnQual def) (Set.toList t))++emptyTuple :: Tuple+emptyTuple = Tuple Set.empty+unionTuple :: Tuple -> Tuple -> Tuple+unionTuple (Tuple a) (Tuple b) = Tuple (a `Set.union` b)++minusTuple :: Tuple -> Set (Name S) -> Tuple+Tuple t `minusTuple` vs = Tuple (t `Set.difference` vs)+intersectTuple :: Tuple -> Set (Name S) -> Tuple+intersectTuple = observe "intersectTuple" intersectTuple'+intersectTuple' :: Tuple -> Set (Name S) -> Tuple+Tuple t `intersectTuple'` vs = Tuple (t `Set.intersection` vs)

@@ -1,245 +0,0 @@-> module ArrCode(->	Arrow,->	bind, anon,->	arr, arrLet, (>>>), arrowExp, applyOp, infixOp, (|||), first,->	VarDecl(VarDecl), letCmd,->	context, anonArgs, toHaskell,->	Tuple(..),->	isEmptyTuple, unionTuple, minusTuple, intersectTuple,->	patternTuple, expTuple,->	returnA_exp, arr_exp, compose_op, choice_op, first_exp,->	left_exp, right_exp, app_exp, loop_exp,->       ifte-> ) where--> import Utils--> import Data.Set (Set)-> import qualified Data.Set as Set-> import Language.Haskell.Syntax--> data Arrow = Arrow {->		code :: Code,->		context :: Tuple, -- named input components used by the arrow->		anonArgs :: Int   -- number of unnamed arguments->	}--> data VarDecl a = VarDecl SrcLoc HsName a->	deriving (Eq,Show)--> instance Functor VarDecl where->	fmap f (VarDecl loc name a) = VarDecl loc name (f a)--> data Code->	= ReturnA			-- returnA = arr id->	| Arr Int HsPat [Binding] HsExp	-- arr (first^n (\p -> ... e))->	| Compose Code [Code] Code	-- composition of 2 or more elts->	| Op HsExp [Code]		-- combinator applied to arrows->	| InfixOp Code HsQOp Code->	| Let [VarDecl Code] Code->       | Ifte HsExp Code Code--> data Binding = BindLet [HsDecl] | BindCase HsPat HsExp--------------------------------------------------------------------------------Arrow constants--> compose_op, choice_op :: HsQOp-> returnA_exp, arr_exp, first_exp :: HsExp-> left_exp, right_exp, app_exp, loop_exp :: HsExp--> returnA_exp	= HsVar (UnQual (HsIdent "returnA"))-> arr_exp	= HsVar (UnQual (HsIdent "arr"))-> compose_op	= HsQVarOp (UnQual (HsSymbol ">>>"))-> choice_op	= HsQVarOp (UnQual (HsSymbol "|||"))-> first_exp	= HsVar (UnQual (HsIdent "first"))-> left_exp	= HsCon (UnQual (HsIdent "Left"))-> right_exp	= HsCon (UnQual (HsIdent "Right"))-> app_exp	= HsVar (UnQual (HsIdent "app"))-> loop_exp	= HsVar (UnQual (HsIdent "loop"))--------------------------------------------------------------------------------Arrow constructors--> bind :: Set HsName -> Arrow -> Arrow-> bind vars a = a {->		context = context a `minusTuple` vars->	}--> anon :: Int -> Arrow -> Arrow-> anon anonCount a = a {->		anonArgs = anonArgs a + anonCount->	}--> arr :: Int -> Tuple -> HsPat -> HsExp -> Arrow-> arr anons t p e = Arrow {->		code = if same p e then ReturnA else Arr anons p [] e,->		context = t `intersectTuple` freeVars e,->		anonArgs = anons->	}->	where	same :: HsPat -> HsExp -> Bool->		same (HsPApp n1 []) (HsCon n2) = n1 == n2->		same (HsPVar n1) (HsVar n2) = UnQual n1 == n2->		same (HsPTuple ps) (HsTuple es) =->			length ps == length es && and (zipWith same ps es)->		same (HsPAsPat n p) e = e == HsVar (UnQual n) || same p e->		same (HsPParen p) e = same p e->		same p (HsParen e) = same p e->		same _ _ = False	-- other cases don't arise--> arrLet :: Int -> Tuple -> HsPat -> [HsDecl] -> HsExp -> Arrow-> arrLet anons t p ds e = Arrow {->		code = Arr anons p [BindLet ds] e,->		context = t `intersectTuple` vs,->		anonArgs = anons->	}->	where	vs = (freeVars e `Set.union` freeVars ds)->				`Set.difference` definedVars ds--> ifte :: HsExp -> Arrow -> Arrow -> Arrow-> ifte c th el = Arrow->             { code = Ifte c (code th) (code el)->             , context = context th `unionTuple` context el->             , anonArgs = 0->             }--> (>>>) :: Arrow -> Arrow -> Arrow-> a1 >>> a2 = a1 { code = compose (code a1) (code a2) }--> arrowExp :: HsExp -> Arrow-> arrowExp e = Arrow {->		code = if e == returnA_exp then ReturnA else Op e [],->		context = emptyTuple,->		anonArgs = 0->	}--> applyOp :: HsExp -> [Arrow] -> Arrow-> applyOp e as = Arrow {->		code = Op e (map code as),->		context = foldr unionTuple emptyTuple (map context as),->		anonArgs = 0	-- BUG: see below->	}--Setting anonArgs to 0 for infixOp is incorrect, but we can't know the-correct value without types.--> infixOp :: Arrow -> HsQOp -> Arrow -> Arrow-> infixOp a1 op a2 = Arrow {->		code = InfixOp (code a1) op (code a2),->		context = context a1 `unionTuple` context a2,->		anonArgs = 0	-- BUG: as above->	}--> first :: Arrow -> Tuple -> Arrow-> first a ps = Arrow {->		code = Op first_exp [code a],->		context = context a `unionTuple` ps,->		anonArgs = 0->	}--> (|||) :: Arrow -> Arrow -> Arrow-> a1 ||| a2 = Arrow {->		code = InfixOp (code a1) choice_op (code a2),->		context = context a1 `unionTuple` context a2,->		anonArgs = 0->	}--> letCmd :: [VarDecl Arrow] -> Arrow -> Arrow-> letCmd defs a = Arrow {->		code = Let (map (fmap code) defs) (code a),->		context = context a,->		anonArgs = anonArgs a->	}--Composition, with some simplification--> compose :: Code -> Code -> Code-> compose ReturnA a = a-> compose a ReturnA = a-> compose a1@(Arr n1 p1 ds1 e1) a2@(Arr n2 p2 ds2 e2)->	| n1 /= n2 = Compose a1 [] a2	-- could do better, but can this arise?->	| same p2 e1 = Arr n1 p1 (ds1 ++ ds2) e2->	| otherwise = Arr n1 p1 (ds1 ++ BindCase p2 e1:ds2) e2->	where	same :: HsPat -> HsExp -> Bool->		same (HsPApp n1 []) (HsCon n2) = n1 == n2->		same (HsPVar n1) (HsVar n2) = UnQual n1 == n2->		same (HsPTuple ps) (HsTuple es) =->			length ps == length es && and (zipWith same ps es)->		same (HsPParen p) e = same p e->		same p (HsParen e) = same p e->		same _ _ = False	-- other cases don't arise-> compose (Compose f1 as1 g1) (Compose f2 as2 g2) =->	Compose f1 (as1 ++ (compose g1 f2 : as2)) g2-> compose a (Compose f bs g) =->	Compose (compose a f) bs g-> compose (Compose f as g) b =->	Compose f as (compose g b)-> compose a1 a2 =->	Compose a1 [] a2--------------------------------------------------------------------------------Conversion to Haskell--> toHaskell :: Arrow -> HsExp-> toHaskell = toHaskellCode . code--> toHaskellCode :: Code -> HsExp-> toHaskellCode ReturnA =->	returnA_exp-> toHaskellCode (Arr n p bs e) =->	HsApp arr_exp->		(times n (HsParen . HsApp first_exp) body)->	where	body = HsParen (HsLambda undefined [p] (foldr addBinding e bs))->		addBinding :: Binding -> HsExp -> HsExp->		addBinding (BindLet ds) e = HsLet ds e->		addBinding (BindCase p e) e' =->			HsCase e [HsAlt undefined p (HsUnGuardedAlt e') []]-> toHaskellCode (Compose f as g) =->	foldr comp (toHaskellArg g) (map toHaskellArg (f:as))->	where	comp f g = HsInfixApp f compose_op g-> toHaskellCode (Op op as) =->	foldl HsApp op (map (paren . toHaskellCode) as)-> toHaskellCode (InfixOp a1 op a2) =->	HsInfixApp (toHaskellArg a1) op (toHaskellArg a2)-> toHaskellCode (Let nas a) =->	HsLet (map toHaskellDecl nas) (toHaskellCode a)->	where	toHaskellDecl (VarDecl loc n a) =->			HsPatBind loc (HsPVar n)->				(HsUnGuardedRhs (toHaskellCode a)) []-> toHaskellCode (Ifte cond th el) = HsIf cond (toHaskellCode th) (toHaskellCode el)--> toHaskellArg :: Code -> HsExp-> toHaskellArg a = parenInfixArg (toHaskellCode a)--------------------------------------------------------------------------------Tuples, representing sets of variables.--> newtype Tuple = Tuple (Set HsName)--Tuple extractors, including matching expression and pattern.--> isEmptyTuple :: Tuple -> Bool-> isEmptyTuple (Tuple t) = Set.null t--> patternTuple :: Tuple -> HsPat-> patternTuple (Tuple t) = tupleP (map HsPVar (Set.toList t))--> expTuple :: Tuple -> HsExp-> expTuple (Tuple t) = tuple (map (HsVar . UnQual) (Set.toList t))--Operations on tuples--> emptyTuple :: Tuple-> emptyTuple = Tuple Set.empty--> unionTuple :: Tuple -> Tuple -> Tuple-> unionTuple (Tuple a) (Tuple b) = Tuple (a `Set.union` b)--Remove all usages of a set of variables.--> minusTuple :: Tuple -> Set HsName -> Tuple-> Tuple t `minusTuple` vs = Tuple (t `Set.difference` vs)--> intersectTuple :: Tuple -> Set HsName -> Tuple-> Tuple t `intersectTuple` vs = Tuple (t `Set.intersection` vs)-

@@ -0,0 +1,243 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module ArrSyn+  ( translate+  ) where++import           ArrCode+import           Utils++import           Control.Monad.Trans.State+import           Data.List                  (mapAccumL)+import           Data.Map                   (Map)+import qualified Data.Map                   as Map+import           Data.Set                   (Set)+import qualified Data.Set                   as Set+import           Debug.Hoed.Pure+import           Language.Haskell.Exts      (Alt (..), Binds (..), Decl (..),+                                             Exp (), GuardedRhs (..),+                                             Match (..), Name, Pat (..),+                                             Rhs (..), Stmt (..), ann)++import qualified Language.Haskell.Exts      as H++-- -----------------------------------------------------------------------------+-- Translation to Haskell++-- This is a 2-phase process:+-- - 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'++transCmd' :: TransState -> Pat S -> Exp S -> Arrow+transCmd' s p (H.LeftArrApp l 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' s p (H.RightArrApp     l f e) = transCmd s p (H.LeftArrApp l e f)+transCmd' s p (H.RightArrHighApp l f e) = transCmd s p (H.LeftArrHighApp l e f)+transCmd' s p (H.InfixApp l c1 op c2) =+  infixOp (transCmd s p c1) op (transCmd s p c2)+transCmd' s p (H.Let l 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) =+   arr 0 (input s) p (H.Case l e as') >>> foldr1 (|||) (reverse cases)+  where+    (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 l ss) =+      transDo s p (init ss) (let Qualifier _ e = last ss in e)+transCmd' s p (H.App l 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 l ps c) =+  anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c+  where+    (s', ps') = addVars' s ps+transCmd' _ _ x = error $ "transCmd: " ++ show x++-- 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)++-- 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++-- 	proc p -> c = arr (first^n (p -> e)) >>> (proc p' -> c)++-- 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++transDo :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow+transDo = observe "transDo" transDo'++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 l 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 (Set.toList defined)))) `intersectTuple`+      defined++data TransState = TransState {+      locals  :: Set (Name S),   -- vars in scope defined in this proc+      cmdVars :: Map (Name S) Arrow+  } deriving (Eq, Generic, Show)++instance Observable TransState++input :: TransState -> Tuple+input s = Tuple (locals s)++addVars'+  :: (Observable a, AddVars a, Eq l, Show l, l ~ LocType a)+  => TransState -> a -> (TransState, a)+addVars' = observe "addVars" addVars++class AddVars a where+      addVars :: TransState -> a -> (TransState, a)++instance AddVars a => AddVars [a] where+      addVars = mapAccumL addVars++instance AddVars a => AddVars (Maybe a) where+  addVars = mapAccumL addVars++instance AddVars (Pat S) where+      addVars s p =+              (s {locals = locals s `Set.union` definedVars p}, p)++instance AddVars (Decl S) where+      addVars s d@(FunBind l (Match _ n _ _ _:_)) =+              (s', d)+              where   (s', _) = addVars s (PVar l n)+      addVars s (PatBind loc p rhs decls) =+              (s', PatBind loc p' rhs decls)+              where   (s', p') = addVars s p+      addVars s d = (s, d)++instance AddVars (Stmt S) where+      addVars s it@Qualifier{} = (s, it)+      addVars s (Generator loc p c) =+              (s', Generator loc p' c)+              where   (s', p') = addVars s p+      addVars s (LetStmt l decls) =+              (s', LetStmt l decls')+              where   (s', decls') = addVars s decls+      addVars s (RecStmt l stmts) =+              (s', RecStmt l stmts')+              where   (s', stmts') = addVars s stmts++instance AddVars (Binds S) where+  addVars s (BDecls l decls) = BDecls l <$> addVars s decls+  addVars s it@IPBinds{}     = (s, it)

@@ -1,304 +0,0 @@-Additional abstract syntax for arrow expressions--> module ArrSyn(->	Cmd(..),->	Stmts, Stmt(..), CmdDecl, VarDecl(..),->	Alt(..), GuardedAlts(..), GuardedAlt(..),->	translate	-- :: HsPat -> Cmd -> HsExp-> ) where--> import ArrCode-> import State		-- Haskell 98 version of Control.Monad.State-> import Utils--> import Data.List(mapAccumL)-> import Data.Map (Map)-> import qualified Data.Map as Map-> import Data.Set (Set)-> import qualified Data.Set as Set-> import Language.Haskell.Syntax--> data Cmd->	= Input HsExp HsExp->	| Kappa SrcLoc [HsPat] Cmd->	| Op HsExp [Cmd]->	| InfixOp Cmd HsQOp Cmd->	| Let [HsDecl] Cmd->	| LetCmd (VarDecl Cmd) Cmd->	| If HsExp Cmd Cmd->	| Case HsExp [Alt]->	| Paren Cmd->	| Do [Stmt] Cmd->	| App Cmd HsExp->	| CmdVar HsName->   deriving (Eq,Show)--> type CmdDecl = (HsName, Cmd)-> type Stmts = ([Stmt], Cmd)--> data Stmt->	= Generator SrcLoc HsPat Cmd->	| RecStmt [Stmt]->	| LetStmt [HsDecl]->	| LetCmdStmt (VarDecl Cmd)->   deriving (Eq,Show)--> data Alt->	= Alt SrcLoc HsPat GuardedAlts [HsDecl]->   deriving (Eq,Show)--> data GuardedAlts->	= UnGuardedAlt Cmd->	| GuardedAlts [GuardedAlt]->   deriving (Eq,Show)--> data GuardedAlt->	= GuardedAlt SrcLoc HsExp Cmd->   deriving (Eq,Show)--------------------------------------------------------------------------------Utilities--> pair :: HsExp -> HsExp -> HsExp-> pair e1 e2 = HsTuple [e1, e2]--Turn redefined variables into wildcards, so the new pattern will be legal.--> pairP :: HsPat -> HsPat -> HsPat-> pairP p1 p2 = HsPTuple [hide p1, p2]->	where	vs = freeVars p2->		hide p@(HsPVar n)->			| n `Set.member` vs = HsPWildCard->			| otherwise = p->		hide (HsPNeg p) = HsPNeg (hide p)->		hide (HsPInfixApp p1 n p2) = HsPInfixApp (hide p1) n (hide p2)->		hide (HsPApp n ps) = HsPApp n (map hide ps)->		hide (HsPTuple ps) = HsPTuple (map hide ps)->		hide (HsPList ps) = HsPList (map hide ps)->		hide (HsPParen p) = HsPParen (hide p)->		hide (HsPRec n pfs) = HsPRec n (map hideField pfs)->			where	hideField (HsPFieldPat f p) =->					HsPFieldPat f (hide p)->		hide (HsPAsPat n p)->			| n `Set.member` vs = hide p->			| otherwise = HsPAsPat n (hide p)->		hide (HsPIrrPat p) = HsPIrrPat (hide p)->		hide p = p--> left, right :: HsExp -> HsExp-> left f = HsApp left_exp (paren f)-> right f = HsApp right_exp (paren f)--> loop :: Arrow -> Arrow-> loop f = applyOp loop_exp [f]--> app, returnA :: Arrow-> app = arrowExp app_exp-> returnA = arrowExp returnA_exp--> returnCmd :: HsExp -> Cmd-> returnCmd = Input returnA_exp--------------------------------------------------------------------------------Translation state--> data TransState = TransState {->	locals :: Set HsName,	-- vars in scope defined in this proc->	cmdVars :: Map HsName Arrow-> }--> input :: TransState -> Tuple-> input s = Tuple (locals s)--> startPattern :: HsPat -> (TransState, HsPat)-> startPattern p =->	(TransState {->		locals = freeVars p,->		cmdVars = Map.empty->	 }, p)--> class AddVars a where->	addVars :: TransState -> a -> (TransState, a)--> instance AddVars a => AddVars [a] where->	addVars = mapAccumL addVars--> instance AddVars HsPat where->	addVars s p =->		(s {locals = locals s `Set.union` freeVars p}, p)---> instance AddVars HsDecl where->	addVars s d@(HsFunBind (HsMatch _ n _ _ _:_)) =->		(s', d)->		where	(s', _) = addVars s (HsPVar n)->	addVars s (HsPatBind loc p rhs decls) =->		(s', HsPatBind loc p' rhs decls)->		where	(s', p') = addVars s p->	addVars s d = (s, d)--------------------------------------------------------------------------------Translation to Haskell--This is a 2-phase process:-- transCmd generates an abstract arrow combinator language represented-  by the Arrow type, and-- toHaskell turns that into Haskell.--> translate :: HsPat -> Cmd -> HsExp-> translate p c = paren (toHaskell (transCmd s p' c))->	where	(s, p') = startPattern 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 -> HsPat -> Cmd -> Arrow-> transCmd s p (Input 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 (Kappa _ ps c) =->	anon (length ps) $ bind (freeVars ps) $->		transCmd s' (foldl pairP p ps') c->	where	(s', ps') = addVars s ps-> transCmd s p (Op op cs) =->	applyOp op (map (transCmd s p) cs)-> transCmd s p (InfixOp c1 op c2) =->	infixOp (transCmd s p c1) op (transCmd s p c2)-> transCmd s p (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 (If 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 (HsIf e (left e1) (right e2)) >>> (a1 ||| a2)->	where	(e1, a1) = transTrimCmd s c1->		(e2, a2) = transTrimCmd s c2-> transCmd s p (Case e as) =->	transCase s p e as-> transCmd s p (Paren c) =->	transCmd s p c-> transCmd s p (Do ss c) =->	transDo s p ss c-> transCmd s p (App c arg) =->	anon (-1) $->	arr (anonArgs a) (input s) p (pair e arg) >>> a->	where	(e, a) = transTrimCmd s c--The following awful hack is there because if the command is recursively-defined, computation of its context will not terminate.  So we plug in-returnA (empty context) to get an arrow whose code is ignored in the-recomputation of the real arrow for a1.-Mutually recursive bindings will be a bit more tricky.--> transCmd s p (LetCmd (VarDecl loc n c1) c2) =->	letCmd [VarDecl loc n a1] (transCmd s' p c2)->	where	(_, a1) = transTrimCmd s' c1->		s' = s { cmdVars = Map.insert n a0 (cmdVars s) }->		s0 = s { cmdVars = Map.insert n returnA (cmdVars s) }->		a0 = transCmd s0 p c1	-- hackety hack-> transCmd s p (CmdVar n) =->	arr (anonArgs a) (input s) p e >>> arrowExp (HsVar (UnQual n))->	where	Just a = Map.lookup n (cmdVars s)->		e = expTuple (context a)--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--	proc p -> c = arr (first^n (p -> e)) >>> (proc p' -> c)--where n is the number of anonymous arguments taken by c.--> transTrimCmd :: TransState -> Cmd -> (HsExp, Arrow)-> transTrimCmd s c = (expTuple (context a), a)->	where	a = transCmd s (patternTuple (context a)) c--> transDo :: TransState -> HsPat -> [Stmt] -> Cmd -> Arrow-> transDo s p [] c =->	transCmd s p 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 = bind (freeVars pg)->			(transDo s' (pairP pg' (patternTuple u)) ss c)->		u = context a->		(eg, ag) = transTrimCmd s cg-> transDo s p (LetStmt decls:ss) c =->	transCmd s p (Let decls (Do ss c))-> transDo s p (RecStmt rss:ss) c =->	bind defined->		(loop (transDo s' (pairP p (irrPat (patternTuple feedback)))->			rss'->			(returnCmd (pair output (expTuple feedback)))->		      ) >>> a)->	where	defined = definedVars rss->		(s', rss') = addVars s rss->		(output, a) = transTrimCmd s' (Do ss c)->		feedback = context (transDo s' p rss'->				(returnCmd (foldr pair output $ map (HsVar . UnQual) $ Set.toList defined)))->			`intersectTuple` defined-> transDo s p (LetCmdStmt vdecl:ss) c =->	transCmd s p (LetCmd vdecl (Do ss c))--The set of variables defined by a list of statements in a rec.--> instance DefinedVars Stmt where->	definedVars (Generator _ p _) = freeVars p->	definedVars (LetStmt decls) = definedVars decls->	definedVars (RecStmt stmts) = definedVars stmts->	definedVars (LetCmdStmt _vdecl) = Set.empty--> instance AddVars Stmt where->	addVars s (Generator loc p c) =->		(s', Generator loc p' c)->		where	(s', p') = addVars s p->	addVars s (LetStmt decls) =->		(s', LetStmt decls')->		where	(s', decls') = addVars s decls->	addVars s (RecStmt stmts) =->		(s', RecStmt stmts')->		where	(s', stmts') = addVars s stmts->	addVars s stmt@(LetCmdStmt _vdecl) =->		(s, stmt)--Translation of case commands uses a right-nested sum,-corresponding to the right-associativity of (|||).-(In future: use a balanced sum.)--The state kept while traversing the expression is-	(count of rhss, rhss in reverse order)--> transCase :: TransState -> HsPat -> HsExp -> [Alt] -> Arrow-> transCase s p e as =->	arr 0 (input s) p (HsCase e as') >>> foldr1 (|||) (reverse cases)->	where	(as', (ncases, cases)) =->			runState (mapM (transAlt s) as) (0, [])->		transAlt s (Alt loc p gas decls) = do->			let	(s', p') = addVars s p->				(s'', decls') = addVars s' decls->			gas' <- transGuardedAlts s'' gas->			return (HsAlt loc p' gas' decls')->		transGuardedAlts s (UnGuardedAlt c) = do->			body <- newAlt s c->			return (HsUnGuardedAlt body)->		transGuardedAlts s (GuardedAlts gas) = do->			gas' <- mapM (transGuardedAlt s) gas->			return (HsGuardedAlts gas')->		transGuardedAlt s (GuardedAlt loc e c) = do->			body <- newAlt s c->			return (HsGuardedAlt loc e body)->		newAlt s c = do->			let (e, a) = transTrimCmd s c->			(n, as) <- get->			put (n+1, a:as)->			return (label n e)->		label n e = times n right->				(if n < ncases-1 then left e else e)

@@ -0,0 +1,23 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Control.Arrow.Notation+  ( translateModule+  , translateExp+  ) where++import           Data.Generics.Uniplate.Data+import           Language.Haskell.Exts       as H hiding (Tuple)++import           ArrSyn+import           Utils++translateModule :: Module SrcSpanInfo -> Module SrcSpanInfo+translateModule = transformBi translateExp++translateExp :: Exp SrcSpanInfo -> Exp SrcSpanInfo+translateExp (Proc _ pat exp) =+  getSrcSpanInfo <$> ArrSyn.translate (fmap S pat) (fmap S exp)+translateExp other = other

@@ -1,24 +1,17 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-} module Control.Arrow.QuasiQuoter   ( proc-  , parseModuleWithMode   ) where -import Data.Maybe+import Control.Arrow.Notation+import Data.List -import Language.Haskell.TH+import Language.Haskell.Exts as Exts hiding (Exp, Loc)+import Language.Haskell.Meta+import Language.Haskell.TH (Exp, Q, Loc(..), location ) import Language.Haskell.TH.Quote -import Language.Haskell.ParseMonad-import Language.Haskell.Syntax-import Language.Haskell.Pretty--import Parser- import Text.Printf  -- | A quasiquoter for arrow notation.@@ -38,136 +31,27 @@   }  quote :: String -> Q Exp-quote inp =-  case parseProc ("proc " ++ inp) of-    ParseOk proc -> tr proc+quote = quoteEx defaultParseMode { extensions = defaultExtensions }++quoteEx :: ParseMode -> String -> Q Exp+quoteEx mode inp =+  case parseExpWithMode mode ("proc " ++ inp) of+    ParseOk proc -> return $ toExp $ translateExp proc     ParseFailed loc err -> do       Loc{..} <- location       error $ printf "%s:%d:%d: %s" loc_filename                                    (fst loc_start + srcLine loc - 1)                                    (snd loc_start + srcColumn loc - 1)                                    err--class Translate hs th | hs -> th where-  tr :: hs -> Q th--trAll xx = traverse tr xx--instance Translate HsExp Exp where-  tr (HsVar name) = VarE <$> tr name-  tr (HsCon (Special HsUnitCon)) = [|()|]-  tr (HsCon (Special HsListCon)) = [|[]|]-  tr (HsCon (Special HsCons)) = [| (:) |]-  tr (HsCon (Special (HsTupleCon 2))) = [| (,) |]-  tr (HsCon (Special (HsTupleCon 3))) = [| (,,) |]-  tr (HsCon (Special (HsTupleCon 4))) = [| (,,,) |]-  tr (HsCon name) = ConE <$> tr name-  tr (HsLit lit)  = LitE <$> tr lit-  tr (HsInfixApp a op b) =-    InfixE <$> (Just <$> tr a) <*> tr op <*> (Just <$> tr b)-  tr (HsApp a b) = AppE <$> tr a <*> tr b-  tr (HsLambda _ pats e) = LamE <$> trAll pats <*> tr e-  tr (HsLet decs e) = LetE <$> trAll decs <*> tr e-  tr (HsIf c t e) = CondE <$> tr c <*> tr t <*> tr e-  tr (HsCase e aa) = CaseE <$> tr e <*> trAll aa-  tr (HsDo ss) = DoE <$> trAll ss-  tr (HsTuple ee) = TupE <$> trAll ee-  tr (HsList ee) = ListE <$> trAll ee-  tr (HsParen e) = ParensE <$> tr e-  tr (HsLeftSection  e op) = InfixE <$> (Just <$> tr e) <*> tr op <*> pure Nothing-  tr (HsRightSection op e) = InfixE <$> pure Nothing    <*> tr op <*> (Just <$> tr e)-  tr (HsRecConstr n ff) = RecConE <$> tr n <*> trAll ff-  tr (HsRecUpdate e ff) = RecUpdE <$> tr e <*> trAll ff-  tr (HsEnumFrom e) = ArithSeqE . FromR <$> tr e-  tr (HsEnumFromThen f t) = ArithSeqE <$> (FromThenR <$> tr f <*> tr t)-  tr (HsEnumFromThenTo f t to) = ArithSeqE <$> (FromThenToR <$> tr f <*> tr t <*> tr to)-  tr (HsEnumFromTo f to) = ArithSeqE <$> (FromToR <$> tr f <*> tr to)-  tr (HsListComp e ss) = (\e ss -> CompE (ss ++ [NoBindS e])) <$> tr e <*> trAll ss-  tr (HsExpTypeSig _ e _) = tr e-  tr HsNegApp{} = error "not applicable"-  tr HsWildCard = error "not applicable"-  tr HsAsPat{} = error "not applicable"-  tr HsIrrPat{} = error "not applicable"--instance Translate HsDecl Dec where-  tr (HsFunBind mm@(HsMatch _ n _ _ _ : _)) = FunD <$> (mkName <$> tr n) <*> trAll mm-  tr (HsPatBind _ p r dd) = ValD <$> tr p <*> tr r <*> trAll dd-  tr _ = error "not implemented: HsDecl"--instance Translate HsMatch Clause where-  tr (HsMatch _ _ pats rhs decls) = Clause <$> trAll pats <*> tr rhs <*> trAll decls--instance Translate HsAlt Match where-  tr (HsAlt _ p aa dd ) = Match <$> tr p <*> tr aa <*> trAll dd--instance Translate HsGuardedAlts Body where-  tr (HsGuardedAlts aa) = GuardedB <$> trAll aa-  tr (HsUnGuardedAlt e) = NormalB <$> tr e--instance Translate HsGuardedAlt (Guard,Exp) where-  tr (HsGuardedAlt _ e e') = (,) <$> (NormalG <$> tr e) <*> tr e'--instance Translate HsStmt Stmt where-  tr (HsGenerator _ p e) = BindS <$> tr p <*> tr e-  tr (HsQualifier e) = NoBindS <$> tr e-  tr (HsLetStmt dd)  = LetS <$> trAll dd--instance Translate HsFieldUpdate FieldExp where-  tr (HsFieldUpdate n e) = (,) <$> tr n <*> tr e--instance Translate HsRhs Body where-  tr (HsUnGuardedRhs e) = NormalB <$> tr e-  tr (HsGuardedRhss gg) = GuardedB <$> trAll gg--instance Translate HsGuardedRhs (Guard,Exp) where-  tr (HsGuardedRhs _ e e') = (,) . NormalG <$> tr e <*> tr e'--instance Translate HsLiteral Lit where-  tr (HsChar c) = pure $ CharL c-  tr (HsString s) = pure $ StringL s-  tr (HsInt i) = pure $ IntPrimL i-  tr (HsFrac f) = pure $ RationalL f-  tr (HsCharPrim c) = pure $ CharPrimL c-  tr (HsIntPrim c) = pure $ IntPrimL c-  tr (HsStringPrim s) = pure $ StringL s-  tr (HsFloatPrim s) = pure $ FloatPrimL s-  tr (HsDoublePrim x) = pure $ DoublePrimL x--instance Translate HsQOp Exp where-  tr (HsQVarOp n) = VarE <$> tr n-  tr (HsQConOp n) = VarE <$> tr n--instance Translate HsPat Pat where-  tr (HsPVar n) = VarP . mkName <$> tr n-  tr (HsPLit l) = LitP <$> tr l-  tr (HsPInfixApp p1 n p2) = InfixP <$> tr p1 <*> tr n <*> tr p2-  tr (HsPApp n pats) = ConP <$> tr n <*> trAll pats-  tr (HsPTuple pats) = TupP <$> trAll pats-  tr (HsPList pats)  = ListP <$> trAll pats-  tr (HsPParen pat)  = ParensP <$> tr pat-  tr (HsPRec n pats) = RecP <$> tr n <*> trAll pats-  tr  HsPWildCard    = return WildP-  tr (HsPIrrPat pat) = TildeP <$> tr pat-  tr HsPNeg{} = error "not implemented: HsPNeg"-  tr HsPAsPat{} = error "not implemented: HsPAsPat"--instance Translate HsPatField FieldPat where-  tr (HsPFieldPat n pat) = (,) <$> tr n <*> tr pat--instance Translate HsQName Name where-  tr (UnQual n) = do-    n <- tr n-    return $ mkName n-  tr (Qual (Module m) n) = do-    n <- tr n-    fromMaybe (error $ printf "Not found: %s.%s" m n) <$> lookupValueName (m ++ "." ++ n)-  tr (Special (HsTupleCon 2)) = error "unhandled Special tuplecon id"-  tr (Special HsUnitCon) =  error "unhandled special unitcon id"-  tr (Special HsListCon) = error "unhandled special listcon id"-  tr (Special HsFunCon) = error "unhandled special funcon id"-  tr (Special HsCons) = error "unhandled special cons id"-+defaultExtensions :: [Extension]+defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions -instance Translate HsName [Char] where-  tr (HsSymbol s) = return s-  tr (HsIdent  n) = return n+badExtensions :: [KnownExtension]+badExtensions =+    [TransformListComp -- steals the group keyword+    ,XmlSyntax, RegularPatterns -- steals a-b+    ,UnboxedTuples -- breaks (#) lens operator+    ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+    ,DoRec, RecursiveDo -- breaks rec+    ,TypeApplications -- HSE fails on @ patterns+    ]

@@ -1,564 +0,0 @@--- #hide--------------------------------------------------------------------------------- |--- Module      :  Lexer--- Copyright   :  (c) The GHC Team, 1997-2000--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Lexer for Haskell.------------------------------------------------------------------------------------- ToDo: Introduce different tokens for decimal, octal and hexadecimal (?)--- ToDo: FloatTok should have three parts (integer part, fraction, exponent) (?)--- ToDo: Use a lexical analyser generator (lx?)--module Lexer (Token(..), lexer) where--import Language.Haskell.ParseMonad--import Data.Char	(isAlpha, isLower, isUpper, toLower,-			 isDigit, isHexDigit, isOctDigit, isSpace,-			 ord, chr, digitToInt)-import Data.Ratio--data Token-        = VarId String-        | QVarId (String,String)-	| ConId String-        | QConId (String,String)-        | VarSym String-        | ConSym String-        | QVarSym (String,String)-        | QConSym (String,String)-	| IntTok Integer-	| FloatTok Rational-	| Character Char-        | StringTok String---- Symbols--	| LeftParen-	| RightParen-	| SemiColon-        | LeftCurly-        | RightCurly-        | VRightCurly			-- a virtual close brace-        | LeftSquare-        | RightSquare-	| Comma-        | Underscore-        | BackQuote---- Reserved operators--	| DotDot-	| Colon-	| DoubleColon-	| Equals-	| Backslash-	| Bar-	| LeftArrow-	| RightArrow-	| At-	| Tilde-	| DoubleArrow-	| Minus-	| Exclamation-	| LeftArrowTail		-- added for arrows-	| RightArrowTail	-- added for arrows-	| LeftArrowDTail	-- added for arrows-	| RightArrowDTail	-- added for arrows-	| LeftBanana		-- added for arrows-	| RightBanana		-- added for arrows---- Reserved Ids--	| KW_Case-	| KW_Class-	| KW_Data-	| KW_Default-	| KW_Deriving-	| KW_Do-	| KW_Else-	| KW_Foreign-	| KW_If-	| KW_Import-	| KW_In-	| KW_Infix-	| KW_InfixL-	| KW_InfixR-	| KW_Instance-	| KW_Let-	| KW_Module-	| KW_NewType-	| KW_Of-	| KW_Then-	| KW_Type-	| KW_Where---- Special Ids--	| KW_As-	| KW_Export-	| KW_Hiding-	| KW_Qualified-	| KW_Safe-	| KW_Unsafe-	| KW_Proc		-- added for arrows-	| KW_Rec		-- added for arrows-	| KW_Form		-- added for arrows-	| KW_Cmd		-- added for arrows--        | EOF-        deriving (Eq,Show)--reserved_ops :: [(String,Token)]-reserved_ops = [- ( "..", DotDot ),- ( ":",  Colon ),- ( "::", DoubleColon ),- ( "=",  Equals ),- ( "\\", Backslash ),- ( "|",  Bar ),- ( "<-", LeftArrow ),- ( "->", RightArrow ),- ( "@",  At ),- ( "~",  Tilde ),- ( "=>", DoubleArrow ),- ( "-<", LeftArrowTail ),	-- added for arrows- ( ">-", RightArrowTail ),	-- added for arrows- ( "-<<", LeftArrowDTail ),	-- added for arrows- ( ">>-", RightArrowDTail ),	-- added for arrows- ( "\\<", Backslash )		-- added for arrows- ]--special_varops :: [(String,Token)]-special_varops = [- ( "-",  Minus ),			--ToDo: shouldn't be here- ( "!",  Exclamation )		--ditto- ]--reserved_ids :: [(String,Token)]-reserved_ids = [- ( "_",         Underscore ),- ( "case",      KW_Case ),- ( "class",     KW_Class ),- ( "cmd",	KW_Cmd ),	-- added for arrows- ( "data",      KW_Data ),- ( "default",   KW_Default ),- ( "deriving",  KW_Deriving ),- ( "do",        KW_Do ),- ( "else",      KW_Else ),- ( "foreign",	KW_Foreign ),- ( "if",    	KW_If ),- ( "import",    KW_Import ),- ( "in", 	KW_In ),- ( "infix", 	KW_Infix ),- ( "infixl", 	KW_InfixL ),- ( "infixr", 	KW_InfixR ),- ( "instance",  KW_Instance ),- ( "let", 	KW_Let ),- ( "module", 	KW_Module ),- ( "newtype",   KW_NewType ),- ( "of", 	KW_Of ),- ( "proc",	KW_Proc ),	-- added for arrows- ( "rec",	KW_Rec ),	-- added for arrows- ( "then", 	KW_Then ),- ( "type", 	KW_Type ),- ( "where", 	KW_Where )- ]--special_varids :: [(String,Token)]-special_varids = [- ( "as", 	KW_As ),- ( "export", 	KW_Export ),- ( "hiding", 	KW_Hiding ),- ( "qualified", KW_Qualified ),- ( "safe",	KW_Safe ),- ( "unsafe", 	KW_Unsafe )- ]--isIdent, isSymbol :: Char -> Bool-isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'-isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"--matchChar :: Char -> String -> Lex a ()-matchChar c msg = do-	s <- getInput-	if null s || head s /= c then fail msg else discard 1---- The top-level lexer.--- We need to know whether we are at the beginning of the line to decide--- whether to insert layout tokens.--lexer :: (Token -> P a) -> P a-lexer = runL $ do-	bol <- checkBOL-	bol <- lexWhiteSpace bol-	startToken-	if bol then lexBOL else lexToken--lexWhiteSpace :: Bool -> Lex a Bool-lexWhiteSpace bol = do-	s <- getInput-	case s of-	    '{':'-':_ -> do-		discard 2-		bol <- lexNestedComment bol-		lexWhiteSpace bol-	    '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do-		lexWhile (== '-')-		lexWhile (/= '\n')-		s' <- getInput-		case s' of-		    [] -> fail "Unterminated end-of-line comment"-		    _ -> do-			lexNewline-			lexWhiteSpace True-	    '\n':_ -> do-		lexNewline-		lexWhiteSpace True-	    '\t':_ -> do-		lexTab-		lexWhiteSpace bol-	    c:_ | isSpace c -> do-		discard 1-		lexWhiteSpace bol-	    _ -> return bol--lexNestedComment :: Bool -> Lex a Bool-lexNestedComment bol = do-	s <- getInput-	case s of-	    '-':'}':_ -> discard 2 >> return bol-	    '{':'-':_ -> do-		discard 2-		bol <- lexNestedComment bol	-- rest of the subcomment-		lexNestedComment bol		-- rest of this comment-	    '\t':_    -> lexTab >> lexNestedComment bol-	    '\n':_    -> lexNewline >> lexNestedComment True-	    _:_       -> discard 1 >> lexNestedComment bol-	    []        -> fail "Unterminated nested comment"---- When we are lexing the first token of a line, check whether we need to--- insert virtual semicolons or close braces due to layout.--lexBOL :: Lex a Token-lexBOL = do-	pos <- getOffside-	case pos of-	    LT -> do-                -- trace "layout: inserting '}'\n" $-        	-- Set col to 0, indicating that we're still at the-        	-- beginning of the line, in case we need a semi-colon too.-        	-- Also pop the context here, so that we don't insert-        	-- another close brace before the parser can pop it.-		setBOL-		popContextL "lexBOL"-		return VRightCurly-	    EQ ->-                -- trace "layout: inserting ';'\n" $-		return SemiColon-	    GT ->-		lexToken--lexToken :: Lex a Token-lexToken = do-    s <- getInput-    case s of-        [] -> return EOF--	'0':c:d:_ | toLower c == 'o' && isOctDigit d -> do-			discard 2-			n <- lexOctal-			return (IntTok n)-		  | toLower c == 'x' && isHexDigit d -> do-			discard 2-			n <- lexHexadecimal-			return (IntTok n)--	'(':'|':c:_ | not (isSymbol c) -> do-	    discard 2-	    return LeftBanana--	'|':')':_ -> do-	    discard 2-	    return RightBanana--	c:_ | isDigit c -> lexDecimalOrFloat--	    | isUpper c -> lexConIdOrQual ""--	    | isLower c || c == '_' -> do-		ident <- lexWhile isIdent-		return $ case lookup ident (reserved_ids ++ special_varids) of-			Just keyword -> keyword-			Nothing -> VarId ident--	    | isSymbol c -> do-		sym <- lexWhile isSymbol-		return $ case lookup sym (reserved_ops ++ special_varops) of-			Just t  -> t-			Nothing -> case c of-			    ':' -> ConSym sym-			    _   -> VarSym sym--	    | otherwise -> do-		discard 1-		case c of--		    -- First the special symbols-		    '(' ->  return LeftParen-		    ')' ->  return RightParen-		    ',' ->  return Comma-		    ';' ->  return SemiColon-		    '[' ->  return LeftSquare-		    ']' ->  return RightSquare-		    '`' ->  return BackQuote-		    '{' -> do-			    pushContextL NoLayout-			    return LeftCurly-		    '}' -> do-			    popContextL "lexToken"-			    return RightCurly--		    '\'' -> do-			    c2 <- lexChar-			    matchChar '\'' "Improperly terminated character constant"-			    return (Character c2)--		    '"' ->  lexString--		    _ ->    fail ("Illegal character \'" ++ show c ++ "\'\n")--lexDecimalOrFloat :: Lex a Token-lexDecimalOrFloat = do-	ds <- lexWhile isDigit-	rest <- getInput-	case rest of-	    ('.':d:_) | isDigit d -> do-		discard 1-		frac <- lexWhile isDigit-		let num = parseInteger 10 (ds ++ frac)-		    decimals = toInteger (length frac)-		exponent <- do-			rest2 <- getInput-			case rest2 of-			    'e':_ -> lexExponent-			    'E':_ -> lexExponent-			    _     -> return 0-		return (FloatTok ((num%1) * 10^^(exponent - decimals)))-	    e:_ | toLower e == 'e' -> do-		exponent <- lexExponent-		return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent))-	    _ -> return (IntTok (parseInteger 10 ds))--    where-	lexExponent :: Lex a Integer-	lexExponent = do-		discard 1	-- 'e' or 'E'-		r <- getInput-		case r of-		    '+':d:_ | isDigit d -> do-			discard 1-			lexDecimal-		    '-':d:_ | isDigit d -> do-			discard 1-			n <- lexDecimal-			return (negate n)-		    d:_ | isDigit d -> lexDecimal-		    _ -> fail "Float with missing exponent"--lexConIdOrQual :: String -> Lex a Token-lexConIdOrQual qual = do-	con <- lexWhile isIdent-	let conid | null qual = ConId con-		  | otherwise = QConId (qual,con)-	    qual' | null qual = con-		  | otherwise = qual ++ '.':con-	just_a_conid <- alternative (return conid)-	rest <- getInput-	case rest of-	  '.':c:_-	     | isLower c || c == '_' -> do	-- qualified varid?-		discard 1-		ident <- lexWhile isIdent-		case lookup ident reserved_ids of-		   -- cannot qualify a reserved word-		   Just _  -> just_a_conid-		   Nothing -> return (QVarId (qual', ident))--	     | isUpper c -> do		-- qualified conid?-		discard 1-		lexConIdOrQual qual'--	     | isSymbol c -> do	-- qualified symbol?-		discard 1-		sym <- lexWhile isSymbol-		case lookup sym reserved_ops of-		    -- cannot qualify a reserved operator-		    Just _  -> just_a_conid-		    Nothing -> return $ case c of-			':' -> QConSym (qual', sym)-			_   -> QVarSym (qual', sym)--	  _ ->	return conid -- not a qualified thing--lexChar :: Lex a Char-lexChar = do-	r <- getInput-	case r of-		'\\':_	-> lexEscape-		c:_	-> discard 1 >> return c-		[]	-> fail "Incomplete character constant"--lexString :: Lex a Token-lexString = loop ""-    where-	loop s = do-		r <- getInput-		case r of-		    '\\':'&':_ -> do-				discard 2-				loop s-		    '\\':c:_ | isSpace c -> do-				discard 1-				lexWhiteChars-				matchChar '\\' "Illegal character in string gap"-				loop s-			     | otherwise -> do-				ce <- lexEscape-				loop (ce:s)-		    '"':_ -> do-				discard 1-				return (StringTok (reverse s))-		    c:_ -> do-				discard 1-				loop (c:s)-		    [] ->	fail "Improperly terminated string"--	lexWhiteChars :: Lex a ()-	lexWhiteChars = do-		s <- getInput-		case s of-		    '\n':_ -> do-			lexNewline-			lexWhiteChars-		    '\t':_ -> do-			lexTab-			lexWhiteChars-		    c:_ | isSpace c -> do-			discard 1-			lexWhiteChars-		    _ -> return ()--lexEscape :: Lex a Char-lexEscape = do-	discard 1-	r <- getInput-	case r of---- Production charesc from section B.2 (Note: \& is handled by caller)--		'a':_		-> discard 1 >> return '\a'-		'b':_		-> discard 1 >> return '\b'-		'f':_		-> discard 1 >> return '\f'-		'n':_		-> discard 1 >> return '\n'-		'r':_		-> discard 1 >> return '\r'-		't':_		-> discard 1 >> return '\t'-		'v':_		-> discard 1 >> return '\v'-		'\\':_		-> discard 1 >> return '\\'-		'"':_		-> discard 1 >> return '\"'-		'\'':_		-> discard 1 >> return '\''---- Production ascii from section B.2--		'^':c:_		-> discard 2 >> cntrl c-		'N':'U':'L':_	-> discard 3 >> return '\NUL'-		'S':'O':'H':_	-> discard 3 >> return '\SOH'-		'S':'T':'X':_	-> discard 3 >> return '\STX'-		'E':'T':'X':_	-> discard 3 >> return '\ETX'-		'E':'O':'T':_	-> discard 3 >> return '\EOT'-		'E':'N':'Q':_	-> discard 3 >> return '\ENQ'-		'A':'C':'K':_	-> discard 3 >> return '\ACK'-		'B':'E':'L':_	-> discard 3 >> return '\BEL'-		'B':'S':_	-> discard 2 >> return '\BS'-		'H':'T':_	-> discard 2 >> return '\HT'-		'L':'F':_	-> discard 2 >> return '\LF'-		'V':'T':_	-> discard 2 >> return '\VT'-		'F':'F':_	-> discard 2 >> return '\FF'-		'C':'R':_	-> discard 2 >> return '\CR'-		'S':'O':_	-> discard 2 >> return '\SO'-		'S':'I':_	-> discard 2 >> return '\SI'-		'D':'L':'E':_	-> discard 3 >> return '\DLE'-		'D':'C':'1':_	-> discard 3 >> return '\DC1'-		'D':'C':'2':_	-> discard 3 >> return '\DC2'-		'D':'C':'3':_	-> discard 3 >> return '\DC3'-		'D':'C':'4':_	-> discard 3 >> return '\DC4'-		'N':'A':'K':_	-> discard 3 >> return '\NAK'-		'S':'Y':'N':_	-> discard 3 >> return '\SYN'-		'E':'T':'B':_	-> discard 3 >> return '\ETB'-		'C':'A':'N':_	-> discard 3 >> return '\CAN'-		'E':'M':_	-> discard 2 >> return '\EM'-		'S':'U':'B':_	-> discard 3 >> return '\SUB'-		'E':'S':'C':_	-> discard 3 >> return '\ESC'-		'F':'S':_	-> discard 2 >> return '\FS'-		'G':'S':_	-> discard 2 >> return '\GS'-		'R':'S':_	-> discard 2 >> return '\RS'-		'U':'S':_	-> discard 2 >> return '\US'-		'S':'P':_	-> discard 2 >> return '\SP'-		'D':'E':'L':_	-> discard 3 >> return '\DEL'---- Escaped numbers--		'o':c:_ | isOctDigit c -> do-					discard 1-					n <- lexOctal-					checkChar n-		'x':c:_ | isHexDigit c -> do-					discard 1-					n <- lexHexadecimal-					checkChar n-		c:_ | isDigit c -> do-					n <- lexDecimal-					checkChar n--		_		-> fail "Illegal escape sequence"--    where-	checkChar n | n <= 0x10FFFF = return (chr (fromInteger n))-	checkChar _		    = fail "Character constant out of range"---- Production cntrl from section B.2--	cntrl :: Char -> Lex a Char-	cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@'))-	cntrl _                        = fail "Illegal control character"---- assumes at least one octal digit-lexOctal :: Lex a Integer-lexOctal = do-	ds <- lexWhile isOctDigit-	return (parseInteger 8 ds)---- assumes at least one hexadecimal digit-lexHexadecimal :: Lex a Integer-lexHexadecimal = do-	ds <- lexWhile isHexDigit-	return (parseInteger 16 ds)---- assumes at least one decimal digit-lexDecimal :: Lex a Integer-lexDecimal = do-	ds <- lexWhile isDigit-	return (parseInteger 10 ds)---- Stolen from Hugs's Prelude-parseInteger :: Integer -> String -> Integer-parseInteger radix ds =-	foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)

@@ -1,997 +0,0 @@-> {-> ------------------------------------------------------------------------------> -- |-> -- Module      :  Parser-> -- Copyright   :  (c) Simon Marlow, Sven Panne 1997-2000-> -- License     :  BSD-style (see the file libraries/base/LICENSE)-> ---> -- Maintainer  :  libraries@haskell.org-> -- Stability   :  experimental-> -- Portability :  portable-> ---> -- Haskell parser.-> ---> ------------------------------------------------------------------------------>-> module Parser (->		parseModule, parseModuleWithMode,->		ParseMode(..), defaultParseMode, ParseResult(..),->   parseProc->   ) where-> -> import Language.Haskell.Syntax-> import Language.Haskell.ParseMonad-> import Lexer-> import Language.Haskell.ParseUtils-> -> import qualified ArrSyn		-- added for arrows-> }--ToDo: Check exactly which names must be qualified with Prelude (commas and friends)-ToDo: Inst (MPCs?)-ToDo: Polish constr a bit-ToDo: Ugly: exp0b is used for lhs, pat, exp0, ...-ToDo: Differentiate between record updates and labeled construction.--------------------------------------------------------------------------------Conflicts: 2 shift/reduce--2 for ambiguity in 'case x of y | let z = y in z :: Bool -> b'-	(don't know whether to reduce 'Bool' as a btype or shift the '->'.-	 Similarly lambda and if.  The default resolution in favour of the-	 shift means that a guard can never end with a type signature.-	 In mitigation: it's a rare case and no Haskell implementation-	 allows these, because it would require unbounded lookahead.)-	There are 2 conflicts rather than one because contexts are parsed-	as btypes (cf ctype).---------------------------------------------------------------------------------> %token->	VARID 	 { VarId $$ }->	QVARID 	 { QVarId $$ }->	CONID	 { ConId $$ }->	QCONID   { QConId $$ }->	VARSYM	 { VarSym $$ }->	CONSYM	 { ConSym $$ }->	QVARSYM	 { QVarSym $$ }->	QCONSYM  { QConSym $$ }->	INT	 { IntTok $$ }->	RATIONAL { FloatTok $$ }->	CHAR	 { Character $$ }->	STRING   { StringTok $$ }--Symbols-->	'('	{ LeftParen }->	')'	{ RightParen }->	';'	{ SemiColon }->	'{'	{ LeftCurly }->	'}'	{ RightCurly }->	vccurly { VRightCurly }			-- a virtual close brace->	'['	{ LeftSquare }->	']'	{ RightSquare }->  	','	{ Comma }->	'_'	{ Underscore }->	'`'	{ BackQuote }--Reserved operators-->	'..'	{ DotDot }->	':'	{ Colon }->	'::'	{ DoubleColon }->	'='	{ Equals }->	'\\'	{ Backslash }->	'|'	{ Bar }->	'<-'	{ LeftArrow }->	'->'	{ RightArrow }->	'@'	{ At }->	'~'	{ Tilde }->	'=>'	{ DoubleArrow }->	'-<'	{ LeftArrowTail }		-- added for arrows->	'>-'	{ RightArrowTail }		-- added for arrows->	'-<<'	{ LeftArrowDTail }		-- added for arrows->	'>>-'	{ RightArrowDTail }		-- added for arrows->	'(|'	{ LeftBanana }			-- added for arrows->	'|)'	{ RightBanana }			-- added for arrows->	'-'	{ Minus }->	'!'	{ Exclamation }--Reserved Ids-->	'case'		{ KW_Case }->	'class'		{ KW_Class }->	'data'		{ KW_Data }->	'default'	{ KW_Default }->	'deriving'	{ KW_Deriving }->	'do'		{ KW_Do }->	'else'		{ KW_Else }->	'foreign'	{ KW_Foreign }->	'if'		{ KW_If }->	'import'	{ KW_Import }->	'in'		{ KW_In }->	'infix'		{ KW_Infix }->	'infixl'	{ KW_InfixL }->	'infixr'	{ KW_InfixR }->	'instance'	{ KW_Instance }->	'let'		{ KW_Let }->	'module'	{ KW_Module }->	'newtype'	{ KW_NewType }->	'of'		{ KW_Of }->	'then'		{ KW_Then }->	'type'		{ KW_Type }->	'where'		{ KW_Where }--Special Ids-->	'as'		{ KW_As }->	'export'	{ KW_Export }->	'hiding'	{ KW_Hiding }->	'qualified'	{ KW_Qualified }->	'safe'		{ KW_Safe }->	'unsafe'	{ KW_Unsafe }->	'proc'		{ KW_Proc }		-- added for arrows->	'rec'		{ KW_Rec }		-- added for arrows->	'cmd'		{ KW_Cmd }		-- added for arrows--> %monad { P }-> %lexer { lexer } { EOF }-> %name parse module-> %name parseProcExp procExp-> %tokentype { Token }-> %%--------------------------------------------------------------------------------Module Header--> module :: { HsModule }->	: srcloc 'module' modid maybeexports 'where' body->		{ HsModule $1 $3 $4 (fst $6) (snd $6) }->	| srcloc body->		{ HsModule $1 main_mod (Just [HsEVar (UnQual main_name)])->							(fst $2) (snd $2) }--> body :: { ([HsImportDecl],[HsDecl]) }->	: '{'  bodyaux '}'			{ $2 }->	| open bodyaux close			{ $2 }--> bodyaux :: { ([HsImportDecl],[HsDecl]) }->	: optsemis impdecls semis topdecls	{ (reverse $2, $4) }->	| optsemis                topdecls	{ ([], $2) }->	| optsemis impdecls optsemis		{ (reverse $2, []) }->	| optsemis				{ ([], []) }--> semis :: { () }->	: optsemis ';'				{ () }--> optsemis :: { () }->	: semis					{ () }->	| {- empty -}				{ () }--------------------------------------------------------------------------------The Export List--> maybeexports :: { Maybe [HsExportSpec] }-> 	:  exports				{ Just $1 }-> 	|  {- empty -}				{ Nothing }--> exports :: { [HsExportSpec] }->	: '(' exportlist optcomma ')'		{ reverse $2 }->	| '(' optcomma ')'			{ [] }--> optcomma :: { () }->	: ','					{ () }->	| {- empty -}				{ () }--> exportlist :: { [HsExportSpec] }-> 	:  exportlist ',' export		{ $3 : $1 }-> 	|  export				{ [$1]  }--> export :: { HsExportSpec }-> 	:  qvar					{ HsEVar $1 }-> 	|  qtyconorcls				{ HsEAbs $1 }-> 	|  qtyconorcls '(' '..' ')'		{ HsEThingAll $1 }-> 	|  qtyconorcls '(' ')'		        { HsEThingWith $1 [] }->	|  qtyconorcls '(' cnames ')'		{ HsEThingWith $1 (reverse $3) }-> 	|  'module' modid			{ HsEModuleContents $2 }--------------------------------------------------------------------------------Import Declarations--> impdecls :: { [HsImportDecl] }->	: impdecls semis impdecl		{ $3 : $1 }->	| impdecl				{ [$1] }--> impdecl :: { HsImportDecl }->	: srcloc 'import' optqualified modid maybeas maybeimpspec->				{ HsImportDecl $1 $4 $3 $5 $6 }--> optqualified :: { Bool }->       : 'qualified'                           { True  }->       | {- empty -}				{ False }--> maybeas :: { Maybe Module }->       : 'as' modid                            { Just $2 }->       | {- empty -}				{ Nothing }---> maybeimpspec :: { Maybe (Bool, [HsImportSpec]) }->	: impspec				{ Just $1 }->	| {- empty -}				{ Nothing }--> impspec :: { (Bool, [HsImportSpec]) }->	: opthiding '(' importlist optcomma ')'	{ ($1, reverse $3) }->	| opthiding '(' optcomma ')'		{ ($1, []) }--> opthiding :: { Bool }->	: 'hiding'				{ True }->	| {- empty -}				{ False }--> importlist :: { [HsImportSpec] }-> 	:  importlist ',' importspec		{ $3 : $1 }-> 	|  importspec				{ [$1]  }--> importspec :: { HsImportSpec }-> 	:  var					{ HsIVar $1 }-> 	|  tyconorcls				{ HsIAbs $1 }-> 	|  tyconorcls '(' '..' ')'		{ HsIThingAll $1 }-> 	|  tyconorcls '(' ')'		        { HsIThingWith $1 [] }-> 	|  tyconorcls '(' cnames ')'		{ HsIThingWith $1 (reverse $3) }--> cnames :: { [HsCName] }-> 	:  cnames ',' cname			{ $3 : $1 }-> 	|  cname				{ [$1]  }--> cname :: { HsCName }->	:  var					{ HsVarName $1 }-> 	|  con					{ HsConName $1 }--------------------------------------------------------------------------------Fixity Declarations--> fixdecl :: { HsDecl }-> 	: srcloc infix prec ops			{ HsInfixDecl $1 $2 $3 (reverse $4) }--> prec :: { Int }->	: {- empty -}				{ 9 }->	| INT					{% checkPrec $1 }--> infix :: { HsAssoc }->	: 'infix'				{ HsAssocNone  }->	| 'infixl'				{ HsAssocLeft  }->	| 'infixr'				{ HsAssocRight }--> ops   :: { [HsOp] }->	: ops ',' op				{ $3 : $1 }->	| op					{ [$1] }--------------------------------------------------------------------------------Top-Level Declarations--Note: The report allows topdecls to be empty. This would result in another-shift/reduce-conflict, so we don't handle this case here, but in bodyaux.--> topdecls :: { [HsDecl] }->	: topdecls1 optsemis		{% checkRevDecls $1 }--> topdecls1 :: { [HsDecl] }->	: topdecls1 semis topdecl	{ $3 : $1 }->	| topdecl			{ [$1] }--> topdecl :: { HsDecl }->	: srcloc 'type' simpletype '=' type->			{ HsTypeDecl $1 (fst $3) (snd $3) $5 }->	| srcloc 'data' ctype '=' constrs deriving->			{% do { (cs,c,t) <- checkDataHeader $3;->				return (HsDataDecl $1 cs c t (reverse $5) $6) } }->	| srcloc 'newtype' ctype '=' constr deriving->			{% do { (cs,c,t) <- checkDataHeader $3;->				return (HsNewTypeDecl $1 cs c t $5 $6) } }->	| srcloc 'class' ctype optcbody->			{% do { (cs,c,vs) <- checkClassHeader $3;->				return (HsClassDecl $1 cs c vs $4) } }->	| srcloc 'instance' ctype optvaldefs->			{% do { (cs,c,ts) <- checkInstHeader $3;->				return (HsInstDecl $1 cs c ts $4) } }->	| srcloc 'default' '(' typelist ')'->			{ HsDefaultDecl $1 $4 }->	| foreigndecl	{ $1 }->       | decl		{ $1 }--> typelist :: { [HsType] }->	: types				{ reverse $1 }->	| type				{ [$1] }->	| {- empty -}			{ [] }--> decls :: { [HsDecl] }->	: optsemis decls1 optsemis	{% checkRevDecls $2 }->	| optsemis			{ [] }--> decls1 :: { [HsDecl] }->	: decls1 semis decl		{ $3 : $1 }->	| decl				{ [$1] }--> decl :: { HsDecl }->	: signdecl			{ $1 }->	| fixdecl			{ $1 }->	| valdef			{ $1 }--> decllist :: { [HsDecl] }->	: '{'  decls '}'		{ $2 }->	| open decls close		{ $2 }--> signdecl :: { HsDecl }->	: srcloc vars '::' ctype	{ HsTypeSig $1 (reverse $2) $4 }--ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var-instead of qvar, we get another shift/reduce-conflict. Consider the-following programs:--   { (+) :: ... }          only var-   { (+) x y  = ... }      could (incorrectly) be qvar--We re-use expressions for patterns, so a qvar would be allowed in patterns-instead of a var only (which would be correct). But deciding what the + is,-would require more lookahead. So let's check for ourselves...--> vars	:: { [HsName] }->	: vars ',' var			{ $3 : $1 }->	| qvar				{% do { n <- checkUnQual $1;->						return [n] } }--Foreign declarations-- calling conventions are uninterpreted-- external entities are not parsed-- special ids are not allowed as internal names--> foreigndecl :: { HsDecl }->	: srcloc 'foreign' 'import' VARID optsafety optentity fvar '::' type->			{ HsForeignImport $1 $4 $5 $6 $7 $9 }->	| srcloc 'foreign' 'export' VARID optentity fvar '::' type->			{ HsForeignExport $1 $4 $5 $6 $8 }--> optsafety :: { HsSafety }->	: 'safe'			{ HsSafe }->	| 'unsafe'			{ HsUnsafe }->	| {- empty -}			{ HsSafe }--> optentity :: { String }->	: STRING			{ $1 }->	| {- empty -}			{ "" }--> fvar :: { HsName }->	: VARID				{ HsIdent $1 }->	| '(' varsym ')'		{ $2 }--------------------------------------------------------------------------------Types--> type :: { HsType }->	: btype '->' type		{ HsTyFun $1 $3 }->	| btype				{ $1 }--> btype :: { HsType }->	: btype atype			{ HsTyApp $1 $2 }->	| atype				{ $1 }--> atype :: { HsType }->	: gtycon			{ HsTyCon $1 }->	| tyvar				{ HsTyVar $1 }->	| '(' types ')'			{ HsTyTuple (reverse $2) }->	| '[' type ']'			{ HsTyApp list_tycon $2 }->	| '(' type ')'			{ $2 }--> gtycon :: { HsQName }->	: qconid			{ $1 }->	| '(' ')'			{ unit_tycon_name }->	| '(' '->' ')'			{ fun_tycon_name }->	| '[' ']'			{ list_tycon_name }->	| '(' commas ')'		{ tuple_tycon_name $2 }---(Slightly edited) Comment from GHC's hsparser.y:-"context => type" vs  "type" is a problem, because you can't distinguish between--	foo :: (Baz a, Baz a)-	bar :: (Baz a, Baz a) => [a] -> [a] -> [a]--with one token of lookahead.  The HACK is to parse the context as a btype-(more specifically as a tuple type), then check that it has the right form-C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!--> ctype :: { HsQualType }->	: context '=>' type		{ HsQualType $1 $3 }->	| type				{ HsQualType [] $1 }--> context :: { HsContext }->	: btype				{% checkContext $1 }--> types	:: { [HsType] }->	: types ',' type		{ $3 : $1 }->	| type  ',' type		{ [$3, $1] }--> simpletype :: { (HsName, [HsName]) }->	: tycon tyvars			{ ($1,reverse $2) }--> tyvars :: { [HsName] }->	: tyvars tyvar			{ $2 : $1 }->	| {- empty -}			{ [] }--------------------------------------------------------------------------------Datatype declarations--> constrs :: { [HsConDecl] }->	: constrs '|' constr		{ $3 : $1 }->	| constr			{ [$1] }--> constr :: { HsConDecl }->	: srcloc scontype		{ HsConDecl $1 (fst $2) (snd $2) }->	| srcloc sbtype conop sbtype	{ HsConDecl $1 $3 [$2,$4] }->	| srcloc con '{' '}'		{ HsRecDecl $1 $2 [] }->	| srcloc con '{' fielddecls '}' { HsRecDecl $1 $2 (reverse $4) }--> scontype :: { (HsName, [HsBangType]) }->	: btype				{% do { (c,ts) <- splitTyConApp $1;->						return (c,map HsUnBangedTy ts) } }->	| scontype1			{ $1 }--> scontype1 :: { (HsName, [HsBangType]) }->	: btype '!' atype		{% do { (c,ts) <- splitTyConApp $1;->						return (c,map HsUnBangedTy ts++->							[HsBangedTy $3]) } }->	| scontype1 satype		{ (fst $1, snd $1 ++ [$2] ) }--> satype :: { HsBangType }->	: atype				{ HsUnBangedTy $1 }->	| '!' atype			{ HsBangedTy   $2 }--> sbtype :: { HsBangType }->	: btype				{ HsUnBangedTy $1 }->	| '!' atype			{ HsBangedTy   $2 }--> fielddecls :: { [([HsName],HsBangType)] }->	: fielddecls ',' fielddecl	{ $3 : $1 }->	| fielddecl			{ [$1] }--> fielddecl :: { ([HsName],HsBangType) }->	: vars '::' stype		{ (reverse $1, $3) }--> stype :: { HsBangType }->	: type				{ HsUnBangedTy $1 }	->	| '!' atype			{ HsBangedTy   $2 }--> deriving :: { [HsQName] }->	: {- empty -}			{ [] }->	| 'deriving' qtycls		{ [$2] }->	| 'deriving' '('          ')'	{ [] }->	| 'deriving' '(' dclasses ')'	{ reverse $3 }--> dclasses :: { [HsQName] }->	: dclasses ',' qtycls		{ $3 : $1 }->       | qtycls			{ [$1] }--------------------------------------------------------------------------------Class declarations--> optcbody :: { [HsDecl] }->	: 'where' decllist		{% checkClassBody $2 }->	| {- empty -}			{ [] }--------------------------------------------------------------------------------Instance declarations--> optvaldefs :: { [HsDecl] }->	: 'where' '{'  valdefs '}'	{% checkClassBody $3 }->	| 'where' open valdefs close	{% checkClassBody $3 }->	| {- empty -}			{ [] }--> valdefs :: { [HsDecl] }->	: optsemis valdefs1 optsemis	{% checkRevDecls $2 }->	| optsemis			{ [] }--> valdefs1 :: { [HsDecl] }->	: valdefs1 semis valdef		{ $3 : $1 }->	| valdef			{ [$1] }--------------------------------------------------------------------------------Value definitions--> valdef :: { HsDecl }->	: srcloc exp0b rhs optwhere	{% checkValDef $1 $2 $3 $4 }--> optwhere :: { [HsDecl] }->	: 'where' decllist		{ $2 }->	| {- empty -}			{ [] }--> rhs	:: { HsRhs }->	: '=' exp			{% do { e <- checkExpr $2;->						return (HsUnGuardedRhs e) } }->	| gdrhs				{ HsGuardedRhss  (reverse $1) }--> gdrhs :: { [HsGuardedRhs] }->	: gdrhs gdrh			{ $2 : $1 }->	| gdrh				{ [$1] }--> gdrh :: { HsGuardedRhs }->	: srcloc '|' exp0 '=' exp	{% do { g <- checkExpr $3;->						e <- checkExpr $5;->						return (HsGuardedRhs $1 g e) } }--------------------------------------------------------------------------------Expressions--Note: The Report specifies a meta-rule for lambda, let and if expressions-(the exp's that end with a subordinate exp): they extend as far to-the right as possible.  That means they cannot be followed by a type-signature or infix application.  To implement this without shift/reduce-conflicts, we split exp10 into these expressions (exp10a) and the others-(exp10b).  That also means that only an exp0 ending in an exp10b (an exp0b)-can followed by a type signature or infix application.  So we duplicate-the exp0 productions to distinguish these from the others (exp0a).--> exp   :: { HsExp }->	: exp0b '::' srcloc ctype  	{ HsExpTypeSig $3 $1 $4 }->	| exp0				{ $1 }--> exp0 :: { HsExp }->	: exp0a				{ $1 }->	| exp0b				{ $1 }--> exp0a :: { HsExp }->	: exp0b qop exp10a		{ HsInfixApp $1 $2 $3 }->	| exp10a			{ $1 }--> exp0b :: { HsExp }->	: exp0b qop exp10b		{ HsInfixApp $1 $2 $3 }->	| exp10b			{ $1 }--> exp10a :: { HsExp }->	: '\\' srcloc apats '->' exp	{ HsLambda $2 (reverse $3) $5 }->  	| 'let' decllist 'in' exp	{ HsLet $2 $4 }->	| 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }->	| procExp { $1 }--> procExp :: { HsExp }-> : 'proc' apat '->' cmd		{ ArrSyn.translate $2 $4 }--> exp10b :: { HsExp }->	: 'case' exp 'of' altslist	{ HsCase $2 $4 }->	| '-' fexp			{ HsNegApp $2 }->  	| 'do' stmtlist			{ HsDo $2 }->	| fexp				{ $1 }--> fexp :: { HsExp }->	: fexp aexp			{ HsApp $1 $2 }->  	| aexp				{ $1 }--> apats :: { [HsPat] }->	: apats apat			{ $2 : $1 }->  	| apat				{ [$1] }--> apat :: { HsPat }->	: aexp				{% checkPattern $1 }--UGLY: Because patterns and expressions are mixed, aexp has to be split into-two rules: One right-recursive and one left-recursive. Otherwise we get two-reduce/reduce-errors (for as-patterns and irrefutable patters).--Even though the variable in an as-pattern cannot be qualified, we use-qvar here to avoid a shift/reduce conflict, and then check it ourselves-(as for vars above).--> aexp	:: { HsExp }->	: qvar '@' aexp			{% do { n <- checkUnQual $1;->						return (HsAsPat n $3) } }->	| '~' aexp			{ HsIrrPat $2 }->  	| aexp1				{ $1 }--Note: The first two alternatives of aexp1 are not necessarily record-updates: they could be labeled constructions.--> aexp1	:: { HsExp }->  	: aexp1 '{' '}' 		{% mkRecConstrOrUpdate $1 [] }->  	| aexp1 '{' fbinds '}' 		{% mkRecConstrOrUpdate $1 (reverse $3) }->  	| aexp2				{ $1 }--According to the Report, the left section (e op) is legal iff (e op x)-parses equivalently to ((e) op x).  Thus e must be an exp0b.--> aexp2	:: { HsExp }->	: qvar				{ HsVar $1 }->	| gcon				{ $1 }->  	| literal			{ HsLit $1 }->	| '(' exp ')'			{ HsParen $2 }->	| '(' texps ')'			{ HsTuple (reverse $2) }->	| '[' list ']'                  { $2 }->	| '(' exp0b qop ')'		{ HsLeftSection $2 $3  }->	| '(' qopm exp0 ')'		{ HsRightSection $2 $3 }->	| '_'				{ HsWildCard }--> commas :: { Int }->	: commas ','			{ $1 + 1 }->	| ','				{ 1 }--> texps :: { [HsExp] }->	: texps ',' exp			{ $3 : $1 }->	| exp ',' exp			{ [$3,$1] }--------------------------------------------------------------------------------List expressions--The rules below are little bit contorted to keep lexps left-recursive while-avoiding another shift/reduce-conflict.--> list :: { HsExp }->	: exp				{ HsList [$1] }->	| lexps 			{ HsList (reverse $1) }->	| exp '..'			{ HsEnumFrom $1 }->	| exp ',' exp '..' 		{ HsEnumFromThen $1 $3 }->	| exp '..' exp	 		{ HsEnumFromTo $1 $3 }->	| exp ',' exp '..' exp		{ HsEnumFromThenTo $1 $3 $5 }->	| exp '|' quals			{ HsListComp $1 (reverse $3) }--> lexps :: { [HsExp] }->	: lexps ',' exp 		{ $3 : $1 }->	| exp ',' exp			{ [$3,$1] }--------------------------------------------------------------------------------List comprehensions--> quals :: { [HsStmt] }->	: quals ',' qual		{ $3 : $1 }->	| qual				{ [$1] }--> qual  :: { HsStmt }->	: pat srcloc '<-' exp		{ HsGenerator $2 $1 $4 }->	| exp				{ HsQualifier $1 }->  	| 'let' decllist		{ HsLetStmt $2 }--------------------------------------------------------------------------------Case alternatives--> altslist :: { [HsAlt] }->	: '{'  alts '}'			{ $2 }->	| open alts close		{ $2 }--> alts :: { [HsAlt] }->	: optsemis alts1 optsemis	{ reverse $2 }--> alts1 :: { [HsAlt] }->	: alts1 semis alt		{ $3 : $1 }->	| alt				{ [$1] }--> alt :: { HsAlt }->	: srcloc pat ralt optwhere	{ HsAlt $1 $2 $3 $4 }--> ralt :: { HsGuardedAlts }->	: '->' exp			{ HsUnGuardedAlt $2 }->	| gdpats			{ HsGuardedAlts (reverse $1) }--> gdpats :: { [HsGuardedAlt] }->	: gdpats gdpat			{ $2 : $1 }->	| gdpat				{ [$1] }--> gdpat	:: { HsGuardedAlt }->	: srcloc '|' exp0 '->' exp	{ HsGuardedAlt $1 $3 $5 }--> pat :: { HsPat }->	: exp0b				{% checkPattern $1 }--------------------------------------------------------------------------------Statement sequences--As per the Report, but with stmt expanded to simplify building the list-without introducing conflicts.  This also ensures that the last stmt is-an expression.--> stmtlist :: { [HsStmt] }->	: '{'  stmts '}'		{ $2 }->	| open stmts close		{ $2 }--> stmts :: { [HsStmt] }->	: 'let' decllist ';' stmts	{ HsLetStmt $2 : $4 }->	| pat srcloc '<-' exp ';' stmts	{ HsGenerator $2 $1 $4 : $6 }->	| exp ';' stmts			{ HsQualifier $1 : $3 }->	| ';' stmts			{ $2 }->	| exp ';'			{ [HsQualifier $1] }->	| exp				{ [HsQualifier $1] }--------------------------------------------------------------------------------Record Field Update/Construction--> fbinds :: { [HsFieldUpdate] }->	: fbinds ',' fbind		{ $3 : $1 }->	| fbind				{ [$1] }--> fbind	:: { HsFieldUpdate }->	: qvar '=' exp			{ HsFieldUpdate $1 $3 }--------------------------------------------------------------------------------Commands (for arrow expressions)-Largely analogous to the treatment of exp (qv), including the distinctions-exp0a/exp0b and exp10a/exp10b.--> cmd :: { ArrSyn.Cmd }->	: exp0b '-<' exp		{ ArrSyn.Input $1 $3 }->	| exp0b '-<<' exp		{ ArrSyn.Input $1 $3 }->	| exp0b '>-' exp		{ ArrSyn.Input $3 $1 }->	| exp0b '>>-' exp		{ ArrSyn.Input $3 $1 }->	| cmd0				{ $1 }--> cmd0 :: { ArrSyn.Cmd }->	: cmd0a				{ $1 }->	| cmd0b				{ $1 }--> cmd0a :: { ArrSyn.Cmd }->	: cmd0b qop cmd10a		{ ArrSyn.InfixOp $1 $2 $3 }->	| cmd10a			{ $1 }--> cmd0b :: { ArrSyn.Cmd }->	: cmd0b qop cmd10b		{ ArrSyn.InfixOp $1 $2 $3 }->	| cmd10b			{ $1 }--> cmd10a :: { ArrSyn.Cmd }->	: '\\' srcloc apats '->' cmd	{ ArrSyn.Kappa $2 (reverse $3) $5 }->	| 'let' decllist 'in' cmd	{ ArrSyn.Let $2 $4 }->	| 'let' cmddecl 'in' cmd	{ ArrSyn.LetCmd $2 $4 }->	| 'if' exp 'then' cmd 'else' cmd { ArrSyn.If $2 $4 $6 }--> cmd10b :: { ArrSyn.Cmd }->	: 'case' exp 'of' altslistA	{ ArrSyn.Case $2 $4 }->	| 'do' stmtlistA		{ ArrSyn.Do (fst $2) (snd $2) }->	| fcmd				{ $1 }--> fcmd :: { ArrSyn.Cmd }->	: fcmd aexp			{ ArrSyn.App $1 $2 }->	| acmd				{ $1 }--> acmd :: { ArrSyn.Cmd }->	: '(' cmd ')'			{ ArrSyn.Paren $2 }->	| '(|' aexp acmds '|)'		{ ArrSyn.Op $2 (reverse $3) }->	| 'cmd' varid			{ ArrSyn.CmdVar $2 }--> acmds :: { [ArrSyn.Cmd] }->	: acmds acmd			{ $2 : $1 }->	| acmd				{ [$1] }--Case commands--> altslistA :: { [ArrSyn.Alt] }->	: '{'  altsA '}'		{ $2 }->	| open altsA close		{ $2 }--> altsA :: { [ArrSyn.Alt] }->	: optsemis alts1A optsemis	{ reverse $2 }--> alts1A :: { [ArrSyn.Alt] }->	: alts1A semis altA		{ $3 : $1 }->	| altA				{ [$1] }--> altA :: { ArrSyn.Alt }->	: srcloc pat raltA optwhere	{ ArrSyn.Alt $1 $2 $3 $4 }--> raltA :: { ArrSyn.GuardedAlts }->	: '->' cmd			{ ArrSyn.UnGuardedAlt $2 }->	| gdpatsA			{ ArrSyn.GuardedAlts (reverse $1) }--> gdpatsA :: { [ArrSyn.GuardedAlt] }->	: gdpatsA gdpatA		{ $2 : $1 }->	| gdpatA			{ [$1] }--> gdpatA :: { ArrSyn.GuardedAlt }->	: srcloc '|' exp0 '->' cmd	{ ArrSyn.GuardedAlt $1 $3 $5 }--The arrow version of do statements--> stmtlistA :: { ArrSyn.Stmts }->	: '{'  stmtsA '}'		{ $2 }->	| open stmtsA close		{ $2 }--Note that stmts/stmtsA must be right-recursive; otherwise it is not-possible, in situations like--	'proc' pat '->' 'do' '(' 'let' decls . ';'--to choose between the productions--	qual -> 'let' decls-	qualA -> 'let' decls--Now that decision is delayed until the trailing exp/cmd is seen.--> stmtsA :: { ArrSyn.Stmts }->	: squalA ';' stmtsA		{ ($1 : fst $3, snd $3) }->	| cmd ';' stmtsA		{ (ArrSyn.Generator undefined HsPWildCard $1 : fst $3, snd $3) }->	| 'let' decllist ';' stmtsA	{ (ArrSyn.LetStmt $2 : fst $4, snd $4) }->	| ';' stmtsA			{ $2 }->	| cmd ';'			{ ([], $1) }->	| cmd				{ ([], $1) }--> squalA :: { ArrSyn.Stmt }->	: pat srcloc '<-' cmd		{ ArrSyn.Generator $2 $1 $4 }->	| cmd '->' srcloc pat		{ ArrSyn.Generator $3 $4 $1 }->	| 'rec' defnsA			{ ArrSyn.RecStmt (reverse $2) }->	| 'let' cmddecl			{ ArrSyn.LetCmdStmt $2 }--> cmddecl :: { ArrSyn.VarDecl ArrSyn.Cmd }->	: srcloc 'cmd' varid '=' cmd	{ ArrSyn.VarDecl $1 $3 $5 }--> defnsA :: { [ArrSyn.Stmt] }->	: '{'  stmts1A '}'		{ $2 }->	| open stmts1A close		{ $2 }--> stmts1A :: { [ArrSyn.Stmt] }->	: stmts1A ';' qualA		{ $3 : $1 }->	| qualA				{ [$1] }--> qualA :: { ArrSyn.Stmt }->	: squalA			{ $1 }->	| 'let' decllist		{ ArrSyn.LetStmt $2 }--------------------------------------------------------------------------------Variables, Constructors and Operators.--> gcon :: { HsExp }->  	: '(' ')'		{ unit_con }->	| '[' ']'		{ HsList [] }->	| '(' commas ')'	{ tuple_con $2 }->  	| qcon			{ HsCon $1 }--> var 	:: { HsName }->	: varid			{ $1 }->	| '(' varsym ')'	{ $2 }--> qvar 	:: { HsQName }->	: qvarid		{ $1 }->	| '(' qvarsym ')'	{ $2 }--> con	:: { HsName }->	: conid			{ $1 }->	| '(' consym ')'        { $2 }--> qcon	:: { HsQName }->	: qconid		{ $1 }->	| '(' gconsym ')'	{ $2 }--> varop	:: { HsName }->	: varsym		{ $1 }->	| '`' varid '`'		{ $2 }--> qvarop :: { HsQName }->	: qvarsym		{ $1 }->	| '`' qvarid '`'	{ $2 }--> qvaropm :: { HsQName }->	: qvarsymm		{ $1 }->	| '`' qvarid '`'	{ $2 }--> conop :: { HsName }->	: consym		{ $1 }	->	| '`' conid '`'		{ $2 }--> qconop :: { HsQName }->	: gconsym		{ $1 }->	| '`' qconid '`'	{ $2 }--> op	:: { HsOp }->	: varop			{ HsVarOp $1 }->	| conop 		{ HsConOp $1 }--> qop	:: { HsQOp }->	: qvarop		{ HsQVarOp $1 }->	| qconop		{ HsQConOp $1 }--> qopm	:: { HsQOp }->	: qvaropm		{ HsQVarOp $1 }->	| qconop		{ HsQConOp $1 }--> gconsym :: { HsQName }->	: ':'			{ list_cons_name }->	| qconsym		{ $1 }--------------------------------------------------------------------------------Identifiers and Symbols--> qvarid :: { HsQName }->	: varid			{ UnQual $1 }->	| QVARID		{ Qual (Module (fst $1)) (HsIdent (snd $1)) }--> varid :: { HsName }->	: VARID			{ HsIdent $1 }->	| 'as'			{ HsIdent "as" }->	| 'export'		{ HsIdent "export" }->	| 'hiding'		{ HsIdent "hiding" }->	| 'qualified'		{ HsIdent "qualified" }->	| 'safe'		{ HsIdent "safe" }->	| 'unsafe'		{ HsIdent "unsafe" }--> qconid :: { HsQName }->	: conid			{ UnQual $1 }->	| QCONID		{ Qual (Module (fst $1)) (HsIdent (snd $1)) }--> conid :: { HsName }->	: CONID			{ HsIdent $1 }--> qconsym :: { HsQName }->	: consym		{ UnQual $1 }->	| QCONSYM		{ Qual (Module (fst $1)) (HsSymbol (snd $1)) }--> consym :: { HsName }->	: CONSYM		{ HsSymbol $1 }--> qvarsym :: { HsQName }->	: varsym		{ UnQual $1 }->	| qvarsym1		{ $1 }--> qvarsymm :: { HsQName }->	: varsymm		{ UnQual $1 }->	| qvarsym1		{ $1 }--> varsym :: { HsName }->	: VARSYM		{ HsSymbol $1 }->	| '-'			{ HsSymbol "-" }->	| '!'			{ HsSymbol "!" }--> varsymm :: { HsName } -- varsym not including '-'->	: VARSYM		{ HsSymbol $1 }->	| '!'			{ HsSymbol "!" }--> qvarsym1 :: { HsQName }->	: QVARSYM		{ Qual (Module (fst $1)) (HsSymbol (snd $1)) }--> literal :: { HsLiteral }->	: INT			{ HsInt $1 }->	| CHAR 			{ HsChar $1 }->	| RATIONAL		{ HsFrac $1 }->	| STRING		{ HsString $1 }--> srcloc :: { SrcLoc }	:	{% getSrcLoc }- -------------------------------------------------------------------------------Layout--> open  :: { () }	:	{% pushCurrentContext }--> close :: { () }->	: vccurly		{ () } -- context popped in lexer.->	| error			{% popContext }--------------------------------------------------------------------------------Miscellaneous (mostly renamings)--> modid :: { Module }->	: CONID			{ Module $1 }->	| QCONID		{ Module (fst $1 ++ '.':snd $1) }--> tyconorcls :: { HsName }->	: conid			{ $1 }--> tycon :: { HsName }->	: conid			{ $1 }--> qtyconorcls :: { HsQName }->	: qconid		{ $1 }--> qtycls :: { HsQName }->	: qconid		{ $1 }--> tyvar :: { HsName }->	: varid			{ $1 }---------------------------------------------------------------------------------> {-> happyError :: P a-> happyError = fail "Parse error"--> -- | Parse of a string, which should contain a complete Haskell 98 module.-> parseModule :: String -> ParseResult HsModule-> parseModule = runParser parse--> -- | Parse of a string, which should contain a complete Haskell 98 module.-> parseModuleWithMode :: ParseMode -> String -> ParseResult HsModule-> parseModuleWithMode mode = runParserWithMode mode parse->-> parseProc :: String -> ParseResult HsExp-> parseProc = runParser parseProcExp-> }

@@ -1,6 +0,0 @@--- A Haskell-98-compatible subset of the Control.Monad.State module.--module State(State, runState, get, put) where--import Control.Monad.Trans.State-

@@ -0,0 +1,187 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeFamilies        #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -Wno-orphans #-}+module Utils+  ( module Utils+  , HSE.Located(..)+  , HSE.rebracket1+  )where++import           Control.Monad+import           Control.Monad.Trans.State+import           Data.Data+import           Data.Default+import           Data.Functor.Identity+import           Data.Generics.Uniplate.Data+import           Data.List+import           Data.Map                      (Map)+import           Data.Set                      (Set)+import qualified Data.Set                      as Set+import           Debug.Hoed.Pure               hiding (Module)+import           Language.Haskell.Exts+import qualified Language.Haskell.Exts.Util    as HSE+#ifdef DEBUG+import           Language.Haskell.Exts.Observe ()+#endif++-- | The type of src code locations used by arrowp-qq+newtype S = S {getSrcSpanInfo :: SrcSpanInfo}+  deriving (Data, Typeable)+instance Eq S where _ == _ = True+instance Ord S where compare _ _ = EQ+instance Show S where show _ = "<loc>"++instance Default S where+  def = S noSrcSpan++instance Observable S where+  observer = observeOpaque "<loc>"+  constrain = constrainBase++freeVars+  :: (Observable a, HSE.FreeVars a, S ~ HSE.LocType a)+  => a -> Set (Name S)+freeVars = observe "freeVars" HSE.freeVars++freeVarss+  :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a)+  => a -> Set (Name S)+freeVarss = observe "freeVarss" (HSE.free . HSE.allVars)++definedVars+  :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a)+  => a -> Set (Name S)+definedVars = observe "definedVars" (HSE.bound . HSE.allVars)++-- | Are a tuple pattern and an expression tuple equal ?+same :: Pat S -> Exp S -> Bool+same = observe "same" same'++same' :: Pat S -> Exp S -> Bool+same' (PApp _ n1 []) (Con _ n2) = n1 == n2+same' (PVar l n1) (Var _ n2) = UnQual l n1 == n2+same' (PTuple _ Boxed []) y = same (PApp (ann y) (unit_con_name (ann y)) []) y+same' (PTuple _ Boxed [pv]) y = same pv y+same' y (Tuple _ Boxed []) = same y (unit_con(ann y))+same' y (Tuple _ Boxed [pv]) = same y pv+same' (PTuple _ boxed ps) (Tuple _ boxed' es) =+  length ps == length es && boxed == boxed' && and (zipWith same ps es)+same' (PAsPat _ n _) (Var _ (UnQual _ n')) = n == n'+same' (PAsPat _ _ p) e = same p e+same' (PParen _ p) e = same p e+same' p (Paren _ e) = same p e+same' _ _ = False++times :: Int -> (a -> a) -> a -> a+times n f x = iterate f x !! n++-- | Hide variables from a pattern+hidePat :: Set (Name S) -> Pat S -> Pat S+hidePat vs = transform (go vs) where+  go vs p@(PVar l n)+    | n `Set.member` vs = PWildCard l+    | otherwise = p+  go vs (PAsPat _ n p)+    | n `Set.member` vs = go vs p+  go _ x = x++pair :: Exp S -> Exp S -> Exp S+pair e1 e2 = Tuple (ann e1) Boxed [e1, e2]++pairP :: Pat S -> Pat S -> Pat S+pairP p1 p2 = PTuple (ann p1) Boxed [hidePat (definedVars p2) p1, p2]++left, right :: Exp S -> Exp S+left  x = App (ann x) left_exp  (Paren def x)+right x = App (ann x) right_exp (Paren def x)++returnCmd :: Exp S -> Exp S+returnCmd x = LeftArrApp (ann x) returnA_exp x++compose_op, choice_op :: QOp S+returnA_exp, arr_exp, first_exp :: Exp S+left_exp, right_exp, app_exp, loop_exp :: Exp S+unqualId :: String -> Exp S+unqualId   id = Var def $ UnQual def (Ident def id)+unqualOp :: String -> QOp S+unqualOp id = QVarOp def $ UnQual def (Symbol def id)+unqualCon :: String -> Exp S+unqualCon  id = Con def $ UnQual def (Symbol def id)+arr_exp       = unqualId "arr"+compose_op    = unqualOp ">>>"+first_exp     = unqualId "first"+returnA_exp   = unqualId "returnA"+choice_op     = unqualOp "|||"+left_exp      = unqualCon "Left"+right_exp     = unqualCon "Right"+app_exp       = unqualId "app"+loop_exp      = unqualId "loop"+++-- | Irrefutable version of a pattern++irrPat :: Pat S -> Pat S+irrPat p@PVar{}       = p+irrPat (PParen l p)   = PParen l (irrPat p)+irrPat (PAsPat l n p) = PAsPat l n (irrPat p)+irrPat p@PWildCard{}  = p+irrPat p@PIrrPat{}    = p+irrPat p              = PIrrPat (ann p) p++-- | Observing functions for algorithmic debugging++observeSt+  :: (Observable a, Observable b, Observable c, Observable s)+  => String -> (a -> b -> State s c) -> a -> b -> State s c+observeSt name f a b = StateT $ \s -> Identity $ observe name f' a b s+  where+    f' a b = runState (f a b)++instance (Eq a, Show a) => Observable (Set a) where+  constrain = constrainBase+  observer = observeBase++instance (Eq a, Eq k, Show a, Show k) => Observable (Map k a) where+  constrain = constrainBase+  observer = observeBase++-- Override some AST instances for comprehension+instance {-# OVERLAPS #-} Observable (Exp S) where+  observer = observePretty+instance {-# OVERLAPS #-} Observable (Name S) where+  observer = observePretty+instance {-# OVERLAPS #-} Observable (QName S) where+  observer = observePretty+instance {-# OVERLAPS #-} Observable [Stmt S] where+  observer lit cxt =+    seq lit $ send (bracket $ intercalate ";" $ fmap prettyPrint lit) (return lit) cxt+instance {-# OVERLAPS #-} Observable (Stmt S) 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+  observer = observePretty+instance {-# OVERLAPS #-} Observable (Rhs S) where+  observer = observePretty+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++observePretty lit cxt =+  seq lit $ send (between "<" ">" $ prettyPrint lit) (return lit) cxt++bracket :: [Char] -> [Char]+between open  close s = open ++ s ++ close+bracket = between "[" "]"

@@ -1,204 +0,0 @@-Miscellaneous utilities on ordinary Haskell syntax used by the arrow-translator.--> module Utils(->	FreeVars(freeVars), DefinedVars(definedVars),->	failureFree, irrPat, paren, parenInfixArg,->	tuple, tupleP,->	times-> ) where--> import Data.Set (Set)-> import qualified Data.Set as Set-> import Language.Haskell.Syntax--The set of free variables in some construct.--> class FreeVars a where->	freeVars :: a -> Set HsName--> instance FreeVars a => FreeVars [a] where->	freeVars = Set.unions . map freeVars--> instance FreeVars HsPat where->	freeVars (HsPVar n) = Set.singleton n->	freeVars (HsPLit _) = Set.empty->	freeVars (HsPNeg p) = freeVars p->	freeVars (HsPInfixApp p1 _ p2) = freeVars p1 `Set.union` freeVars p2->	freeVars (HsPApp _ ps) = freeVars ps->	freeVars (HsPTuple ps) = freeVars ps->	freeVars (HsPList ps) = freeVars ps->	freeVars (HsPParen p) = freeVars p->	freeVars (HsPRec _ pfs) = freeVars pfs->	freeVars (HsPAsPat n p) = Set.insert n (freeVars p)->	freeVars (HsPWildCard) = Set.empty->	freeVars (HsPIrrPat p) = freeVars p--> instance FreeVars HsPatField where->	freeVars (HsPFieldPat _ p) = freeVars p--> instance FreeVars HsFieldUpdate where->	freeVars (HsFieldUpdate _ e) = freeVars e--> instance FreeVars HsExp where->	freeVars (HsVar n) = freeVars n->	freeVars (HsCon _) = Set.empty->	freeVars (HsLit _) = Set.empty->	freeVars (HsInfixApp e1 op e2) =->		freeVars e1 `Set.union` freeVars op `Set.union` freeVars e2->	freeVars (HsApp f e) = freeVars f `Set.union` freeVars e->	freeVars (HsNegApp e) = freeVars e->	freeVars (HsLambda _ ps e) = freeVars e `Set.difference` freeVars ps->	freeVars (HsLet decls e) =->		(freeVars decls `Set.union` freeVars e) `Set.difference`->			definedVars decls->	freeVars (HsIf e1 e2 e3) =->		freeVars e1 `Set.union` freeVars e2 `Set.union` freeVars e3->	freeVars (HsCase e as) = freeVars e `Set.union` freeVars as->	freeVars (HsDo ss) = freeVarsStmts ss->	freeVars (HsTuple es) = freeVars es->	freeVars (HsList es) = freeVars es->	freeVars (HsParen e) = freeVars e->	freeVars (HsLeftSection e op) = freeVars e `Set.union` freeVars op->	freeVars (HsRightSection op e) = freeVars op `Set.union` freeVars e->	freeVars (HsRecConstr _ us) = freeVars us->	freeVars (HsRecUpdate e us) = freeVars e `Set.union` freeVars us->	freeVars (HsEnumFrom e) = freeVars e->	freeVars (HsEnumFromTo e1 e2) = freeVars e1 `Set.union` freeVars e2->	freeVars (HsEnumFromThen e1 e2) = freeVars e1 `Set.union` freeVars e2->	freeVars (HsEnumFromThenTo e1 e2 e3) =->		freeVars e1 `Set.union` freeVars e2 `Set.union` freeVars e3->	freeVars (HsListComp e ss) =->		freeVars e `Set.union` freeVarsStmts ss->	freeVars (HsExpTypeSig _ e _) = freeVars e->	freeVars (HsAsPat _ _) = error "freeVars (x @ p)"->	freeVars (HsWildCard) = error "freeVars _"->	freeVars (HsIrrPat _) = error "freeVars ~p"--> instance FreeVars HsQOp where->	freeVars (HsQVarOp n) = freeVars n->	freeVars (HsQConOp _) = Set.empty--> instance FreeVars HsQName where->	freeVars (UnQual v) = Set.singleton v->	freeVars _ = Set.empty--> instance FreeVars HsAlt where->	freeVars (HsAlt _ p gas decls) =->		(freeVars gas `Set.union` freeVars decls) `Set.difference`->		(freeVars p `Set.union` definedVars decls)--> instance FreeVars HsGuardedAlts where->	freeVars (HsUnGuardedAlt e) = freeVars e->	freeVars (HsGuardedAlts alts) = freeVars alts--> instance FreeVars HsGuardedAlt where->	freeVars (HsGuardedAlt _ e1 e2) = freeVars e1 `Set.union` freeVars e2--> instance FreeVars HsDecl where->	freeVars (HsFunBind ms) = freeVars ms->	freeVars (HsPatBind _ p rhs decls) =->		(freeVars rhs `Set.union` freeVars decls) `Set.difference`->		(freeVars p `Set.union` definedVars decls)->	freeVars _ = Set.empty--> instance FreeVars HsMatch where->	freeVars (HsMatch _ n ps rhs decls) =->		(freeVars rhs `Set.union` freeVars decls) `Set.difference`->		(Set.insert n (freeVars ps) `Set.union` definedVars decls)--> instance FreeVars HsRhs where->	freeVars (HsUnGuardedRhs e) = freeVars e->	freeVars (HsGuardedRhss grs) = freeVars grs--> instance FreeVars HsGuardedRhs where->	freeVars (HsGuardedRhs _ e1 e2) = freeVars e1 `Set.union` freeVars e2--> freeVarsStmts :: [HsStmt] -> Set HsName-> freeVarsStmts = foldr addStmt Set.empty->	where	addStmt (HsGenerator _ p e) s =->			freeVars e `Set.union` (s `Set.difference` freeVars p)->		addStmt (HsQualifier e) _s = freeVars e->		addStmt (HsLetStmt decls) s =->			(freeVars decls `Set.union` s) `Set.difference` definedVars decls--The set of variables defined by a construct.--> class DefinedVars a where->	definedVars :: a -> Set HsName--> instance DefinedVars a => DefinedVars [a] where->	definedVars = Set.unions . map definedVars--> instance DefinedVars HsDecl where->	definedVars (HsFunBind (HsMatch _ n _ _ _:_)) = Set.singleton n->	definedVars (HsPatBind _ p _ _) = freeVars p->	definedVars _ = Set.empty--Is the pattern failure-free?-(This is incomplete at the moment, because patterns made with unique-constructors should be failure-free, but we have no way of detecting them.)--> failureFree :: HsPat -> Bool-> failureFree (HsPVar _) = True-> failureFree (HsPApp n ps) = n == unit_con_name && null ps-> failureFree (HsPTuple ps) = all failureFree ps-> failureFree (HsPParen p) = failureFree p-> failureFree (HsPAsPat _ p) = failureFree p-> failureFree (HsPWildCard) = True-> failureFree (HsPIrrPat _) = True-> failureFree _ = False--Irrefutable version of a pattern--> irrPat :: HsPat -> HsPat-> irrPat p@(HsPVar _) = p-> irrPat (HsPParen p) = HsPParen (irrPat p)-> irrPat (HsPAsPat n p) = HsPAsPat n (irrPat p)-> irrPat p@(HsPWildCard) = p-> irrPat p@(HsPIrrPat _) = p-> irrPat p = HsPIrrPat p--Make an expression into an aexp, by adding parentheses if required.--> paren :: HsExp -> HsExp-> paren e = if isAexp e then e else HsParen e->	where	isAexp (HsVar _) = True->		isAexp (HsCon _) = True->		isAexp (HsLit _) = True->		isAexp (HsParen _) = True->		isAexp (HsTuple _) = True->		isAexp (HsList _) = True->		isAexp (HsEnumFrom _) = True->		isAexp (HsEnumFromTo _ _) = True->		isAexp (HsEnumFromThen _ _) = True->		isAexp (HsEnumFromThenTo _ _ _) = True->		isAexp (HsListComp _ _) = True->		isAexp (HsLeftSection _ _) = True->		isAexp (HsRightSection _ _) = True->		isAexp (HsRecConstr _ _) = True->		isAexp (HsRecUpdate _ _) = True->		isAexp _ = False--Make an expression into an fexp, by adding parentheses if required.--> parenInfixArg :: HsExp -> HsExp-> parenInfixArg e@(HsApp _ _) = e-> parenInfixArg e = paren e--Tuples--> tuple :: [HsExp] -> HsExp-> tuple [] = unit_con-> tuple [e] = e-> tuple es = HsTuple es--> tupleP :: [HsPat] -> HsPat-> tupleP [] = HsPApp unit_con_name []-> tupleP [e] = e-> tupleP es = HsPTuple es--Compose a function n times.--> times :: Int -> (a -> a) -> a -> a-> times n f a = foldr ($) a (replicate n f)