packages feed

arrowp-qq 0.2.0.1 → 0.2.1

raw patch · 20 files changed

+694/−571 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

README.md view
@@ -52,7 +52,7 @@ **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:+3. It extends the desugaring to handle static conditional expressions. Example: ``` proc inputs -> do   results <- processor -< inputs
arrowp-qq.cabal view
@@ -1,5 +1,5 @@ Name:           arrowp-qq-Version:        0.2.0.1+Version:        0.2.1 Cabal-Version:  >= 1.20 Build-Type:     Simple License:        GPL@@ -46,7 +46,7 @@        Build-Depends:       NoHoed      Hs-Source-Dirs: src-    Other-Modules:  ArrCode ArrSyn Utils+    Other-Modules:  ArrCode ArrSyn NewCode SrcLocs Utils     Default-Language:    Haskell2010  executable arrowp-ext@@ -76,23 +76,25 @@                  examples,                  examples/cgi,                  examples/circuits,-                 examples/Parser,+                 examples/parser,                  examples/powertrees,                  examples/small   main-is:             Main.hs   other-modules:                               Parser,                        ExprParser,-                       BackStateArrow,+                       BackstateArrow,                        Conditional,                        ListOps,                        Egs,                        Eval,                        Eval1,+                       GHC,                         Lift,                        ListOps,+                       Static,                        TH.TH,                        TH.While,-                       TH.BackStateArrow+                       TH.BackstateArrow   build-depends:     base, arrows, arrowp-qq, template-haskell
+ examples/GHC.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE Arrows #-}+module GHC where++import Control.Arrow++ghc,trivial :: Arrow a => a inp chunk -> a chunk out -> a inp out+trivial chunk process = proc inputs -> do+   chunked <- chunk -< inputs+   results <- process -< chunked+   returnA -< results++ghc chunk process =+  arr(\inputs -> (inputs,inputs)) >>> first chunk >>> first process >>> arr fst
examples/Main.hs view
@@ -8,11 +8,13 @@ import           Eval              () import           Eval1             () import           ExprParser        ()+import           GHC               () import           Hom               () import           Lift              () import           ListOps           ()-import           TH.TH             ()+import           Static            () import           TH.BackstateArrow ()+import           TH.TH             () import           TH.While          ()
− examples/Parser/ExprParser.lhs 
@@ -1,91 +0,0 @@-> {-# 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
− examples/Parser/Parser.lhs 
@@ -1,254 +0,0 @@-> {-# 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)
+ examples/Static.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS -F -pgmF arrowp-ext #-}+module Static where++import Control.Arrow++ifEx :: Arrow a => Bool -> a inp out -> a out () -> a inp out+ifEx outputResultsArg processor outputSink = proc inputs -> do+  results <- processor -< inputs+  if outputResultsArg+    then outputSink -< results+    else returnA -< ()+  processor -< results++ifEx' :: Arrow a => Bool -> a inp out -> a out () -> a inp out+ifEx' outputResultsArg processor outputSink = proc inputs -> do+  results <- processor -< inputs+  results <- if outputResultsArg+    then outputSink -< results+    else returnA -< results+  processor -< results++caseEx :: Arrow a => Bool -> a inp out -> a out () -> a inp out+caseEx outputResultsArg processor outputSink = proc inputs -> do+  results <- processor -< inputs+  case outputResultsArg of+    True -> outputSink -< results+    False -> returnA -< ()+  processor -< results++caseEx' :: Arrow a => Bool -> a inp out -> a out () -> a inp out+caseEx' outputResultsArg processor outputSink = proc inputs -> do+  results <- processor -< inputs+  results <- case outputResultsArg of+               True -> outputSink -< results+               False -> returnA -< results+  processor -< results
− examples/TH/BackStateArrow.hs 
@@ -1,39 +0,0 @@-{-# 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') |]
+ examples/TH/BackstateArrow.hs view
@@ -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') |]
+ examples/parser/ExprParser.lhs view
@@ -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
+ examples/parser/Parser.lhs view
@@ -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)
− examples/small/BackStateArrow.hs 
@@ -1,39 +0,0 @@-{- 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')
+ examples/small/BackstateArrow.hs view
@@ -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')
examples/small/Egs.hs view
@@ -18,3 +18,13 @@ 				while p s -< x 			else 				returnA -< ()++rightApp f = proc x -> do+  y <- x >- f+  () >- returnA+  not y >- returnA++identity f = proc x -> do+  y <- f -< x+  y' <- id -< y+  returnA -< y
src/ArrCode.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor        #-} {-# LANGUAGE DeriveGeneric        #-} {-# LANGUAGE FlexibleContexts     #-}@@ -9,7 +11,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}  module ArrCode-  ( Arrow+  ( Arrow(..)   , bind   , anon   , arr@@ -19,7 +21,6 @@   , infixOp   , (|||)   , first-  , VarDecl   , context   , anonArgs   , toHaskell@@ -28,15 +29,6 @@   , intersectTuple   , patternTuple   , expTuple-  , returnA_exp-  , arr_exp-  , compose_op-  , choice_op-  , first_exp-  , left_exp-  , right_exp-  , app_exp-  , loop_exp   , ifte   , app   , loop@@ -45,70 +37,25 @@ import           Data.Set                     (Set) import qualified Data.Set                     as Set import           Debug.Hoed.Pure-import           Language.Haskell.Exts.Syntax hiding (Let, Tuple)+import           Language.Haskell.Exts.Syntax hiding (Tuple) import qualified Language.Haskell.Exts.Syntax as H+import           NewCode import           Utils  data Arrow = Arrow   { context  :: Tuple -- named input components used by the arrow   , anonArgs :: Int     -- number of unnamed arguments-  , code     :: Code+  , code     :: Exp Code   }   deriving (Eq, Generic, Show)  instance Located Arrow  where-  type LocType Arrow = S+  type LocType Arrow = Code   location f (Arrow context anon code)=-    Arrow <$> location f context <*> pure anon <*> location f code+    Arrow context 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] @@ -125,15 +72,15 @@   Arrow   { code =       if same p e-        then ReturnA-        else Arr anons p [] e+        then ReturnA (ann e)+        else Arr (ann e) anons (Loc <$> p) [] (Loc <$> 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+  { code = Arr (ann e) anons (Loc <$> p) [BindLet (Loc <$> ds)] (Loc <$> e)   , context = t `intersectTuple` vs   , anonArgs = anons   }@@ -143,7 +90,7 @@ ifte :: Exp S -> Arrow -> Arrow -> Arrow ifte c th el =   Arrow-  { code = Ifte c (code th) (code el)+  { code = If (Loc$ ann c) (Loc <$> c) (code th) (code el)   , context = context th `unionTuple` context el   , anonArgs = 0   }@@ -154,15 +101,15 @@   Arrow   { code =       if e == returnA_exp-        then ReturnA-        else Op e []+        then ReturnA (ann e)+        else Op (Loc <$> e) []   , context = emptyTuple   , anonArgs = 0   } applyOp :: Exp S -> [Arrow] -> Arrow applyOp e as =   Arrow-  { code = Op e (map code as)+  { code = Op (Loc <$> e) (map code as)   , context = foldr (unionTuple . context) emptyTuple as   , anonArgs = 0 -- BUG: see below   }@@ -170,7 +117,7 @@ infixOp :: Arrow -> QOp S -> Arrow -> Arrow infixOp a1 op a2 =   Arrow-  { code = InfixOp (code a1) op (code a2)+  { code = InfixApp def (code a1) (Loc <$> op) (code a2)   , context = context a1 `unionTuple` context a2   , anonArgs = 0 -- BUG: as above   }@@ -184,21 +131,21 @@ (|||) :: Arrow -> Arrow -> Arrow a1 ||| a2 =   Arrow-  { code = InfixOp (code a1) choice_op (code a2)+  { code = InfixApp def (code a1) (choice_op) (code a2)   , context = context a1 `unionTuple` context a2   , anonArgs = 0   } -compose :: Code -> Code -> Code+compose :: Exp Code -> Exp Code -> Exp 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)+compose' :: Exp Code -> Exp Code -> Exp Code+compose' ReturnA{} a = a+compose' a ReturnA{} = a+compose' a1@(Arr l1 n1 p1 ds1 e1) a2@(Arr l2 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+  | same p2 e1 = Arr l1 n1 p1 (ds1 ++ ds2) e2+  | otherwise = Arr l1 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@@ -208,33 +155,42 @@ 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)+    toHaskellCode :: Exp Code -> Exp S+    toHaskellCode (ReturnA l) = const l <$> returnA_exp @ S+    toHaskellCode (Arr l n p bs e) =+      App l 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+        body :: Exp S+        body = Lambda def [getLoc <$> p] (foldr addBinding (getLoc <$> e) bs)+        addBinding :: Binding -> Exp S -> Exp S+        addBinding (BindLet ds) e = H.Let def (getLoc <$> ds) e         addBinding (BindCase p e) e' =-          Case def e [Alt def p (UnGuardedRhs def e') Nothing]+          Case def (getLoc <$> e) [Alt def (getLoc <$> 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)-+    toHaskellCode (Op op as) =+      foldl (App def) (getLoc <$> op) (map (Paren def . toHaskellCode) as)+    toHaskellCode (InfixApp (Loc l) a1 op a2) =+      InfixApp l (toHaskellArg a1) (getLoc <$> op) (toHaskellArg a2)+    toHaskellCode (Let (Loc l) bb a) =+      H.Let l (getLoc <$> bb) (toHaskellCode a)+    toHaskellCode (If (Loc l) cond th el) =+      If l (getLoc <$> cond) (toHaskellCode th) (toHaskellCode el)+    toHaskellCode (Case (Loc l) e alts) =+      Case l (getLoc <$> e) (toHaskellAlt <$> alts)+    toHaskellAlt (Alt (Loc l) pat rhs binds) =+      Alt l (getLoc <$> pat) (toHaskellRhs rhs) (getLoc <$$> binds)+    toHaskellRhs (UnGuardedRhs (Loc l) e) = UnGuardedRhs l (toHaskellCode e)+    toHaskellRhs (GuardedRhss (Loc l) rhss) =+      GuardedRhss l (toHaskellGuardedRhs <$> rhss)+    toHaskellGuardedRhs (GuardedRhs (Loc l) stmts e) =+      GuardedRhs l (getLoc <$$> stmts) (toHaskellCode e)     toHaskellArg = Paren def . toHaskellCode  newtype Tuple = Tuple (Set (Name S))-  deriving (Eq,Generic,Show)+  deriving (Eq,Generic,Monoid,Show) instance Observable Tuple  instance Located Tuple where
src/ArrSyn.hs view
@@ -11,9 +11,11 @@   ) where  import           ArrCode+import           NewCode import           Utils  import           Control.Monad.Trans.State+import           Control.Monad.Trans.Writer import           Data.List                  (mapAccumL) import           Data.Map                   (Map) import qualified Data.Map                   as Map@@ -56,17 +58,19 @@ transCmd = observe "transCmd" transCmd'  transCmd' :: TransState -> Pat S -> Exp S -> Arrow-transCmd' s p (H.LeftArrApp l f e)+transCmd' s p (H.LeftArrApp _ f e)       | Set.null (freeVars f `Set.intersection` locals s) =               arr 0 (input s) p e >>> arrowExp f       | otherwise =               arr 0 (input s) p (pair f e) >>> app transCmd' s p (H.LeftArrHighApp  l f e) = transCmd s p (H.LeftArrApp l f e)-transCmd' 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) =+transCmd' _ _ H.RightArrApp{} =+  error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"+transCmd' _ _ H.RightArrHighApp{} =+  error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"+transCmd' s p (H.InfixApp _ c1 op c2) =   infixOp (transCmd s p c1) op (transCmd s p c2)-transCmd' s p (H.Let l decls c) =+transCmd' s p (H.Let _ decls c) =       arrLet (anonArgs a) (input s) p decls' e >>> a       where   (s', decls') = addVars' s decls               (e, a) = transTrimCmd s' c@@ -77,9 +81,20 @@       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) =+transCmd' s p (H.Case l e as)+  | Set.null (freeVars e `Set.intersection` locals s) =+    Arrow {+      context = ctx,+      anonArgs = 0,+      code = H.Case (Loc l) (Loc <$> e) alts+          }+  | otherwise =    arr 0 (input s) p (H.Case l e as') >>> foldr1 (|||) (reverse cases)   where+    (alts, ctx) = runWriter $ flip traverseAlts (Loc <$$> as) $ \exp -> do+      let arrow = transCmd s p (getLoc <$> exp)+      tell $ context arrow+      return $ code arrow     (as', (ncases, cases)) = runState (mapM (transAlt s) as) (0, [])     transAlt = observeSt "transAlt" transAlt'     transAlt' s (Alt loc p gas decls) = do@@ -115,13 +130,13 @@            else e) transCmd' s p (H.Paren _ c) =       transCmd s p c-transCmd' s p (H.Do l ss) =+transCmd' s p (H.Do _ ss) =       transDo s p (init ss) (let Qualifier _ e = last ss in e)-transCmd' s p (H.App l c arg) =+transCmd' s p (H.App _ c arg) =       anon (-1) $       arr (anonArgs a) (input s) p (pair e arg) >>> a       where   (e, a) = transTrimCmd s c-transCmd' s p (H.Lambda l ps c) =+transCmd' s p (H.Lambda _ ps c) =   anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c   where     (s', ps') = addVars' s ps@@ -153,7 +168,7 @@       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 =+transDo' s p (Generator _ pg cg:ss) c =       if isEmptyTuple u then         transCmd s p cg >>> transDo s' pg ss c       else
src/Control/Arrow/Notation.hs view
@@ -20,4 +20,6 @@ translateExp :: Exp SrcSpanInfo -> Exp SrcSpanInfo translateExp (Proc _ pat exp) =   getSrcSpanInfo <$> ArrSyn.translate (fmap S pat) (fmap S exp)+translateExp (RightArrApp l e f) = LeftArrApp l f e+translateExp (RightArrHighApp l e f) = LeftArrHighApp l f e translateExp other = other
+ src/NewCode.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE PatternSynonyms    #-}+{-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE ViewPatterns       #-}+module NewCode where++import           Data.Data+import           Data.Default+import           Debug.Hoed.Pure+import           GHC.Generics                  (Generic)+import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Exts.Util+import           SrcLocs+#ifdef DEBUG+import           Language.Haskell.Exts.Observe ()+#endif++-- | AST annotations to extend the Haskell AST with an arrow core language+data Code+  = ReturnCode S+  | ArrCode S Int [Binding]+  | ComposeCode+  | OpCode+  | Loc S+  deriving (Eq, Data, Ord, Generic, Show)++instance Default Code where+  def = Loc def++instance Observable Code++getLoc :: Code -> S+getLoc (Loc s) = s+getLoc other   = error $ "getLoc: " ++ show other++pattern ReturnA l = ExprHole (ReturnCode l)+pattern Arr l i pat bb e = Lambda (ArrCode l i bb) [pat] e+pattern Compose a bb c <- List ComposeCode ( split -> (a,bb,c) )+  where+    Compose a bb c = List ComposeCode (a : bb ++ [c])++pattern Op e args = List OpCode (e:args)++split :: [c] -> (c, [c], c)+split (h:rest@(_:_)) = (h, init rest, last rest)+split _              = error "Compose: unreachable"++data Binding = BindLet (Binds Code) | BindCase (Pat Code) (Exp Code)+  deriving (Eq, Data, Ord, Generic, Show)++instance Observable Binding++instance Located Binding where+  type LocType Binding = Code+  location f (BindLet b)    = BindLet <$> location f b+  location f (BindCase p e) = BindCase <$> location f p <*> location f e
+ src/SrcLocs.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveDataTypeable #-}+module SrcLocs where++import           Data.Data+import           Data.Default+import           Debug.Hoed.Pure+import           Language.Haskell.Exts++-- | 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
src/Utils.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE OverloadedLists     #-}@@ -15,7 +14,6 @@   , freeVars   , freeVarss   , definedVars-  , hidePat   , irrPat   , left, right   , pair@@ -25,13 +23,15 @@   , app_exp   , arr_exp   , first_exp-  , left_exp, right_exp   , loop_exp   , returnA_exp   , choice_op   , compose_op   , returnCmd   , observeSt+  , (<$$>)+  , traverseAlt+  , traverseAlts   )where  import           Control.Monad@@ -50,41 +50,41 @@ #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+import SrcLocs+import NewCode  freeVars-  :: (Observable a, HSE.FreeVars a, S ~ HSE.LocType a)-  => a -> Set (Name S)+  :: ( Observable a+     , Observable (Set (Name code))+     , HSE.FreeVars a+     , code ~ HSE.LocType a+     )+  => a -> Set (Name code) freeVars = observe "freeVars" HSE.freeVars  freeVarss-  :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a)-  => a -> Set (Name S)+  :: ( Observable a+     , Observable (Set (Name code))+     , HSE.AllVars a+     , code ~ HSE.LocType a+     )+  => a -> Set (Name code) freeVarss = observe "freeVarss" (HSE.free . HSE.allVars)  definedVars-  :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a)-  => a -> Set (Name S)+  :: ( Observable a+     , Observable (Set (Name code))+     , HSE.AllVars a+     , code ~ HSE.LocType a+     )+  => a -> Set (Name code) definedVars = observe "definedVars" (HSE.bound . HSE.allVars)  -- | Are a tuple pattern and an expression tuple equal ?-same :: Pat S -> Exp S -> Bool+same :: (Eq s, Observable(Exp s), Observable(Pat s)) => Pat s -> Exp s -> Bool same = observe "same" same' -same' :: Pat S -> Exp S -> Bool+same' :: (Eq s, Observable(Exp s), Observable(Pat s)) => 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@@ -112,27 +112,27 @@     | n `Set.member` vs = go vs p   go _ x = x -pair :: Exp S -> Exp S -> Exp S+pair :: Exp code -> Exp code -> Exp code 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, right :: Default code => Exp code -> Exp code 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 :: Default code => Exp code -> Exp code 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+compose_op, choice_op :: Default s => QOp s+returnA_exp, arr_exp, first_exp :: Default s => Exp s+left_exp, right_exp, app_exp, loop_exp :: Default s => Exp s+unqualId :: Default s => String -> Exp s unqualId   id = Var def $ UnQual def (Ident def id)-unqualOp :: String -> QOp S+unqualOp :: Default s => String -> QOp s unqualOp id = QVarOp def $ UnQual def (Symbol def id)-unqualCon :: String -> Exp S+unqualCon :: Default s => String -> Exp s unqualCon  id = Con def $ UnQual def (Symbol def id) arr_exp       = unqualId "arr" compose_op    = unqualOp ">>>"@@ -173,7 +173,7 @@   observer = observeBase  -- Override some AST instances for comprehension-instance {-# OVERLAPS #-} Observable (Exp S) where+instance {-# OVERLAPS #-} Observable (Exp Code) where   observer = observePretty instance {-# OVERLAPS #-} Observable (Name S) where   observer = observePretty@@ -184,7 +184,7 @@     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+instance {-# OVERLAPS #-} Observable (Pat Code) where   observer = observePretty instance {-# OVERLAPS #-} Observable (QOp S) where   observer = observePretty@@ -205,3 +205,11 @@ bracket :: [Char] -> [Char] between open  close s = open ++ s ++ close bracket = between "[" "]"++(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+(<$$>) f = fmap (fmap f)++traverseAlt :: (Data s, Monad a) => (Exp s -> a(Exp s)) -> Alt s -> a(Alt s)+traverseAlt = descendBiM+traverseAlts :: (Data s, Monad a) => (Exp s -> a(Exp s)) -> [Alt s] -> a [Alt s]+traverseAlts = traverse.traverseAlt